spatstat.geom/0000755000176200001440000000000014766261237013061 5ustar liggesusersspatstat.geom/tests/0000755000176200001440000000000014611065354014212 5ustar liggesusersspatstat.geom/tests/testsP2.R0000644000176200001440000001626614611065354015714 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' #' tests/ppp.R #' #' $Revision: 1.14 $ $Date: 2022/08/27 04:49:32 $ #' #' Untested cases in ppp() or associated code local({ ## X <- runifpoint(10, letterR) ## Y <- runifpoint(10, complement.owin(letterR)) Bin <- owin(c(2.15, 2.45), c(0.85, 3.0)) Bout <- owin(c(2.75, 2.92), c(0.85, 1.4)) X <- runifrect(10, Bin)[letterR] Y <- runifrect(10, Bout)[complement.owin(letterR)] if(FULLTEST) { #' test handling of points out-of-bounds df <- rbind(as.data.frame(X), as.data.frame(Y)) A <- ppp(df$x, df$y, window=letterR, marks=1:20) #' test handling of points with bad coordinates df$x[1:3] <- c(Inf, NA, NaN) df$y[18:20] <- c(Inf, NA, NaN) B <- ppp(df$x, df$y, window=letterR, marks=1:20) D <- ppp(df$x, df$y, window=letterR, marks=data.frame(id=1:20, u=runif(20))) #' test print/summary/plot methods on these bad objects print(A) print(B) print(D) print(summary(A)) print(summary(B)) print(summary(D)) plot(A) plot(B) plot(D) plot(attr(A, "rejects")) plot(attr(B, "rejects")) plot(attr(D, "rejects")) #' subset operator --- cases not covered elsewhere #' subset index is a logical image Z <- distmap(letterR, invert=TRUE) V <- (Z > 0.2) XV <- X[V] #' multiple columns of marks fun3 <- finpines[1:3] #' multiple columns of marks, one of which is a factor U <- finpines marks(U)[,2] <- factor(c(rep("A", 60), rep("B", npoints(U)-60))) UU <- U[1:3, drop=TRUE] #' cut.ppp CU <- cut(U, "height") CU <- cut(U, breaks=3) #' cases of [<-.ppp set.seed(999) X <- cells B <- square(0.2) X[B] <- runifrect(3, B) #' checking 'value' Y <- flipxy(X) X[B] <- Y[square(0.3)] ## deprecated use of second argument X[,1:4] <- runifrect(3) # deprecated X[,B] <- runifrect(3, B) # deprecated X[1:3, B] <- runifrect(20) A <- superimpose(cells, X, W="convex") A <- superimpose(cells, X, W=ripras) B <- superimpose(concatxy(cells), concatxy(X), W=NULL) ## superimpose.splitppp Y <- superimpose(split(amacrine)) ## catch outdated usage of scanpp d <- system.file("rawdata", "amacrine", package="spatstat.data") if(nzchar(d)) { W <- owin(c(0, 1060/662), c(0, 1)) Y <- scanpp("amacrine.txt", dir=d, window=W, multitype=TRUE) print(Y) } ## (bad) usage of cobble.xy xx <- runif(10) yy <- runif(10) W1 <- cobble.xy(xx, yy) W2 <- cobble.xy(xx, yy, boundingbox) Wnope <- cobble.xy(xx, yy, function(x,y) {cbind(x,y)}, fatal=FALSE) ## as.data.frame.ppplist Z <- runifrect(3, nsim=4) Z[[2]] <- Z[[2]][1] Z[[3]] <- Z[[3]][FALSE] d <- as.data.frame(Z) } }) # # tests/ppx.R # # Test operations for ppx objects # # $Revision: 1.9 $ $Date: 2020/12/04 04:49:40 $ # local({ if(ALWAYS) { ## make data df <- data.frame(x=c(1,2,2,1)/4, y=c(1,2,3,1)/4, z=c(2,3,4,3)/5) X <- ppx(data=df, coord.type=rep("s", 3), domain=box3()) } if(ALWAYS) { #' methods involving C code unique(X) duplicated(X) anyDuplicated(X) multiplicity(X) uniquemap(X) } if(FULLTEST) { #' general tests print(X) summary(X) plot(X) domain(X) unitname(X) <- c("metre", "metres") unitname(X) #' subset operator X[integer(0)] Y <- X %mark% data.frame(a=df$x, b=1:4) Y[1:2] Y[FALSE] marks(Y) <- as.data.frame(marks(Y)) Y[integer(0)] Y[1:2] Y[FALSE] } if(FULLTEST) { #' two dimensional A <- ppx(data=df[,1:2], coord.type=rep("s", 2), domain=square(1)) plot(A) B <- ppx(data=df[,1:2], coord.type=rep("s", 2), domain=NULL) plot(B) #' one dimensional E <- ppx(data=data.frame(x=runif(10))) plot(E) #' bug stopifnot(identical(unmark(chicago[1]), unmark(chicago)[1])) #' ppx with zero points U <- chicago[integer(0)] V <- U %mark% 1 V <- U %mark% factor("a") #' simplify lower-dimensional patterns X3 <- ppx(data=df, coord.type=rep("s", 3), domain=box3(), simplify=TRUE) stopifnot(is.pp3(X3)) X2 <- ppx(data=df[,1:2], coord.type=rep("s", 2), domain=square(1), simplify=TRUE) stopifnot(is.ppp(X2)) #' marks<-.ppx M <- as.matrix(X) marks(X) <- df[,1] marks(X) <- df[,integer(0)] } if(FULLTEST) { ## ............ from Ege .......................... ## Tests for shift: ## Check ppp and ppx shift are the same X <- cells Y <- ppx(coords(cells), domain = boxx(0:1,0:1)) Xs <- shift(X, vec = c(1,1)) Ys <- shift(Y, vec = c(1,1)) stopifnot(all.equal(coords(Xs), coords(Ys), check.attributes = FALSE)) stopifnot(all.equal(domain(Xs), as.owin(domain(Ys)), check.attributes = FALSE)) ## Check a single numeric for vec in shift.ppx stopifnot(identical(Ys, shift(Y, vec = 1))) ## Tests for scale: dat <- data.frame(x=1:3, y=1:3, m=letters[1:3]) xrange <- yrange <- c(0,4) cent <- c(2,2) scal <- c(5,5) X <- as.ppp(dat, W = owin(xrange, yrange)) Xscaled <- affine(shift(X, vec = -cent), mat = diag(1/scal)) ## Check ppx without domain: Y <- ppx(dat, coord.type = c("spatial", "spatial", "mark")) Yscaled <- scale(Y, center = cent, scale = scal) stopifnot(all.equal(coords(Xscaled), coords(Yscaled), check.attributes = FALSE)) ## Check ppx with domain: Y$domain <- boxx(xrange, yrange) Yscaled <- scale(Y, center = cent, scale = scal) stopifnot(all.equal(as.boxx(Window(Xscaled)), domain(Yscaled), check.attributes = FALSE)) ## Tests for intersect.boxx: ## Should be unit 2D box: A <- intersect.boxx(boxx(c(-1,1),c(0,2)), boxx(c(0,3),c(0,1))) stopifnot(identical(A, boxx(c(0,1),c(0,1)))) ## Should be empty (NULL) B <- intersect.boxx(boxx(c(-1,1),c(0,2)), boxx(c(0,3),c(0,1)), boxx(c(1,2), c(-1,1))) stopifnot(is.null(B)) ## Should be unit 3D box: C <- intersect.boxx(boxx(c(-1,1),c(0,2),c(-1,1)), boxx(c(0,3),c(0,1),c(0,4))) stopifnot(identical(C, boxx(c(0,1),c(0,1),c(0,1)))) ## Should be empty (NULL) D <- intersect.boxx(boxx(c(-1,1),c(0,2),c(-1,1)), boxx(c(0,3),c(0,1),c(0,4)), NULL) stopifnot(is.null(D)) ## Tests for [.boxx with clip: ## Check ppp and ppx subset with clip are the same X <- cells WX <- shift(domain(X), vec = c(.5,.5)) X2 <- X[WX, clip=TRUE] Y <- ppx(coords(X), domain = boxx(c(0,1),c(0,1))) WY <- shift(domain(Y), vec = c(.5,.5)) Y2 <- Y[WY, clip=TRUE] stopifnot(all.equal(coords(X2), coords(Y2), check.attributes = FALSE)) stopifnot(all.equal(domain(X2), as.owin(domain(Y2)))) } }) spatstat.geom/tests/selfcross.txt0000755000176200001440000000071514611065354016764 0ustar liggesusers x y 0.3057897 0.1518920 0.6038506 0.3132859 0.6343093 0.2740279 0.5364061 0.2936569 0.8170620 0.4681368 0.8083595 0.6535217 0.6125531 0.6796937 0.6103774 0.6360737 0.4363273 0.6338927 0.4689617 0.6927797 0.6538900 0.7560286 0.6169043 0.7756576 0.5994993 0.7276756 0.3514779 0.7363996 0.3123166 0.6622457 0.1447933 0.4877658 0.2274671 0.4332408 0.1578471 0.3721728 0.2753309 0.4027068 0.1817790 0.4136118 0.2100621 0.3067429 spatstat.geom/tests/testsK.R0000644000176200001440000000065414611065354015617 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) spatstat.geom/tests/testsM.R0000644000176200001440000000244214611065354015616 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' tests/morpho.R #' #' morphology code blocks #' #' $Revision: 1.3 $ $Date: 2020/04/30 02:18:23 $ local({ if(ALWAYS) { # depends on C code etc #' owin a <- erosion(letterR, 0.1, polygonal=FALSE) b <- dilation(letterR, 0.1, polygonal=FALSE) at <- erosion(letterR, 0.1, polygonal=FALSE, strict=TRUE) bt <- dilation(letterR, 0.1, polygonal=FALSE, tight=FALSE) #' psp S <- edges(letterR) dm <- dilation(S, 0.1, polygonal=FALSE) dt <- dilation(S, 0.1, polygonal=FALSE, tight=FALSE) op <- spatstat.options(old.morpho.psp=TRUE) dn <- dilation(S, 0.1, polygonal=TRUE) spatstat.options(op) cS <- closing(S, 0.1, polygonal=FALSE) eS <- erosion(S, 0) oS <- opening(S, 0) #' ppp dc <- dilation(cells, 0.06, polygonal=FALSE) ec <- erosion(cells, 0) oc <- opening(cells, 0) #' reset.spatstat.options() } }) spatstat.geom/tests/testsEtoF.R0000644000176200001440000000625214611065354016262 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) # tests/emptymarks.R # # test cases where there are no (rows or columns of) marks # # $Revision: 1.4 $ $Date: 2020/04/28 12:58:26 $ if(ALWAYS) { local({ n <- npoints(cells) df <- data.frame(x=1:n, y=factor(sample(letters, n, replace=TRUE))) nocolumns <- c(FALSE, FALSE) norows <- rep(FALSE, n) X <- cells marks(X) <- df marks(X) <- df[,1] marks(X) <- df[,nocolumns] Z <- Y <- X[integer(0)] marks(Y) <- df[norows,] stopifnot(is.marked(Y)) marks(Z) <- df[norows,nocolumns] stopifnot(!is.marked(Z)) }) } # # tests/factorbugs.R # # check for various bugs related to factor conversions # # $Revision: 1.8 $ $Date: 2023/01/30 00:51:42 $ # if(ALWAYS) { local({ ## make a factor image m <- factor(rep(letters[1:4], 4)) Z <- im(m, xcol=1:4, yrow=1:4) ## make a point pattern set.seed(42) X <- runifrect(20, win=as.owin(Z)) ## look up the image at the points of X ## (a) internal ans1 <- lookup.im(Z, X$x, X$y) stopifnot(is.factor(ans1)) ## (b) user level ans2 <- Z[X] stopifnot(is.factor(ans2)) ## (c) turn the image into a tessellation ## and apply quadratcount V <- tess(image = Z) quadratcount(X, tess=V) ## Pad image Y <- padimage(Z, factor("b", levels=levels(Z))) stopifnot(Y$type == "factor") U <- padimage(Z, "b") stopifnot(U$type == "factor") ## Manipulate factor levels Zb <- relevel(Z, "b") Zv <- mergeLevels(Z, vowel="a", consonant=c("b","c","d")) P <- X %mark% Z[X] Pv <- mergeLevels(P, vowel="a", consonant=c("b","c","d")) ## Harmonise factor levels - cases not covered Flat <- factor(sample(letters[1:3], 10, replace=TRUE)) Image <- gorillas.extra$slopetype oo <- harmoniseLevels() oo <- harmoniseLevels(Flat) oo <- harmoniseLevels(A=Image) oo <- harmoniseLevels(A=Flat,B=Image) }) } # # tests/func.R # # $Revision: 1.9 $ $Date: 2022/10/23 00:48:40 $ # # Tests of 'funxy' infrastructure etc if(FULLTEST) { local({ ## Check the peculiar function-building code in funxy W <- square(1) f1a <- function(x, y) sqrt(x^2 + y^2) F1a <- funxy(f1a, W) f1b <- function(x, y) { sqrt(x^2 + y^2) } f2a <- function(x, y) sin(x) f2b <- function(x, y) { sin(x) } f3a <- function(x, y) sin(x) + cos(x) f3b <- function(x, y) { sin(x) + cos(x) } f4a <- function(x, y) { z <- x + y ; z } f4b <- function(x, y) { x + y } F1b <- funxy(f1b, W) F2a <- funxy(f2a, W) F2b <- funxy(f2b, W) F3a <- funxy(f3a, W) F3b <- funxy(f3b, W) F4a <- funxy(f4a, W) F4b <- funxy(f4b, W) stopifnot(identical(F1a(cells), F1b(cells))) stopifnot(identical(F2a(cells), F2b(cells))) stopifnot(identical(F3a(cells), F3b(cells))) stopifnot(identical(F4a(cells), F4b(cells))) ## check coordinate extraction from objects X <- runifrect(9) Q <- quadscheme(X) a <- F1a(X) d <- F1a(Q) }) } spatstat.geom/tests/badwindow.txt0000755000176200001440000005451114611065354016742 0ustar liggesusers x y i 486959 6497047 1 487223 6497012 1 487293 6497170 1 487434 6497187 1 487504 6497047 1 487539 6496959 1 487557 6496889 1 488875 6496924 1 488945 6496643 1 490808 6496643 1 490737 6496854 1 490298 6497644 1 490140 6498541 1 490298 6498857 1 490491 6497855 1 490948 6496854 1 491036 6496555 1 491950 6496537 1 491282 6500298 1 491282 6501546 1 491124 6501792 1 491124 6501985 1 491563 6502319 1 491493 6502740 1 491475 6503355 1 491686 6504375 1 491616 6505324 1 490772 6505675 1 490526 6506237 1 489683 6506237 1 489490 6505605 1 489578 6505359 1 489191 6505078 1 488892 6504023 1 488910 6503795 1 488716 6503812 1 488611 6504568 1 488031 6505201 1 487522 6505042 1 487522 6504919 1 487486 6504849 1 487416 6504884 1 487399 6504814 1 487346 6504832 1 487240 6504638 1 487117 6504515 1 487117 6503935 1 487276 6504006 1 487346 6503971 1 487399 6503865 1 487486 6503812 1 487574 6503777 1 487557 6503689 1 487082 6503303 1 486994 6502266 1 487205 6501159 1 487117 6500526 1 487188 6499437 1 487012 6498259 1 486924 6497029 1 487186 6499396 2 487182 6499396 2 487186 6499426 2 487186 6499396 2 487126 6500589 2 487126 6500476 2 487156 6500476 2 487156 6500176 2 487186 6500176 2 487186 6499462 2 487117 6500526 2 487126 6500589 2 487156 6500686 2 487140 6500686 2 487156 6500805 2 487156 6500686 2 487186 6500986 2 487181 6500986 2 487186 6501021 2 487186 6500986 2 487216 6501076 2 487194 6501076 2 487205 6501159 2 487187 6501256 2 487216 6501256 2 487216 6501076 2 487186 6501406 2 487186 6501260 2 487158 6501406 2 487186 6501406 2 487156 6501466 2 487156 6501417 2 487147 6501466 2 487156 6501466 2 487096 6501766 2 487096 6501732 2 487090 6501766 2 487096 6501766 2 487066 6502936 2 487066 6502636 2 487096 6502636 2 487096 6502606 2 487156 6502606 2 487156 6502486 2 487066 6502486 2 487066 6502456 2 487036 6502456 2 487036 6502156 2 487015 6502156 2 486994 6502266 2 487064 6503086 2 487066 6503086 2 487066 6503112 2 487066 6503116 2 487156 6503116 2 487156 6503026 2 487126 6503026 2 487126 6502996 2 487096 6502996 2 487096 6502936 2 487066 6502936 2 488956 6501496 3 488956 6501256 3 488926 6501256 3 488926 6501046 3 488896 6501046 3 488896 6500806 3 488866 6500806 3 488866 6500506 3 488836 6500506 3 488836 6500236 3 488806 6500236 3 488806 6499996 3 488776 6499996 3 488776 6499486 3 488686 6499486 3 488686 6499126 3 488716 6499126 3 488716 6499006 3 488626 6499006 3 488626 6499036 3 488596 6499036 3 488596 6499066 3 488566 6499066 3 488566 6499126 3 488536 6499126 3 488536 6499216 3 488416 6499216 3 488416 6499456 3 488446 6499456 3 488446 6499696 3 488416 6499696 3 488416 6499936 3 488446 6499936 3 488446 6500056 3 488476 6500056 3 488476 6500146 3 488506 6500146 3 488506 6500266 3 488536 6500266 3 488536 6500386 3 488566 6500386 3 488566 6500656 3 488536 6500656 3 488536 6500986 3 488566 6500986 3 488566 6501136 3 488536 6501136 3 488536 6501376 3 488566 6501376 3 488566 6501406 3 488596 6501406 3 488596 6501496 3 488566 6501496 3 488566 6501616 3 488596 6501616 3 488596 6501796 3 488626 6501796 3 488626 6502036 3 488656 6502036 3 488656 6502096 3 488686 6502096 3 488686 6502246 3 488716 6502246 3 488716 6502276 3 488776 6502276 3 488776 6502336 3 488806 6502336 3 488806 6502426 3 488836 6502426 3 488836 6502636 3 488866 6502636 3 488866 6502666 3 488926 6502666 3 488926 6502696 3 488986 6502696 3 488986 6502726 3 489046 6502726 3 489046 6502756 3 489136 6502756 3 489136 6502096 3 489106 6502096 3 489106 6501976 3 489076 6501976 3 489076 6501826 3 489046 6501826 3 489046 6501736 3 489016 6501736 3 489016 6501586 3 488986 6501586 3 488986 6501496 3 490216 6502426 4 490216 6502246 4 490246 6502246 4 490246 6502186 4 490306 6502186 4 490306 6501946 4 490216 6501946 4 490216 6502096 4 490186 6502096 4 490186 6502156 4 490036 6502156 4 490036 6502126 4 489946 6502126 4 489946 6502096 4 489916 6502096 4 489916 6502066 4 489826 6502066 4 489826 6502036 4 489796 6502036 4 489796 6501946 4 489706 6501946 4 489706 6502036 4 489736 6502036 4 489736 6502186 4 489766 6502186 4 489766 6502216 4 489796 6502216 4 489796 6502276 4 489946 6502276 4 489946 6502306 4 489976 6502306 4 489976 6502336 4 490006 6502336 4 490006 6502366 4 490036 6502366 4 490036 6502426 4 488642 6504346 5 488716 6503812 5 488910 6503795 5 488892 6504023 5 488926 6504143 5 488926 6503806 5 488956 6503806 5 488956 6503686 5 488986 6503686 5 488986 6503566 5 489016 6503566 5 489016 6503476 5 489046 6503476 5 489046 6503386 5 489076 6503386 5 489076 6503296 5 489106 6503296 5 489106 6503206 5 489136 6503206 5 489136 6503086 5 489166 6503086 5 489166 6502846 5 489046 6502846 5 489046 6503086 5 488926 6503086 5 488926 6503236 5 488746 6503236 5 488746 6503266 5 488536 6503266 5 488536 6503296 5 488506 6503296 5 488506 6503326 5 488416 6503326 5 488416 6503386 5 488326 6503386 5 488326 6503506 5 488356 6503506 5 488356 6503536 5 488416 6503536 5 488416 6503566 5 488446 6503566 5 488446 6503656 5 488626 6503656 5 488626 6503746 5 488656 6503746 5 488656 6503776 5 488686 6503776 5 488686 6503956 5 488656 6503956 5 488656 6503986 5 488626 6503986 5 488626 6504046 5 488596 6504046 5 488596 6504076 5 488566 6504076 5 488566 6504106 5 488536 6504106 5 488536 6504166 5 488506 6504166 5 488506 6504226 5 488476 6504226 5 488476 6504346 5 489886 6503386 6 489886 6503146 6 489916 6503146 6 489916 6503056 6 489736 6503056 6 489736 6503206 6 489706 6503206 6 489706 6503266 6 489676 6503266 6 489676 6503356 6 489796 6503356 6 489796 6503596 6 489916 6503596 6 489916 6503386 6 490006 6505666 7 489916 6505666 7 489916 6505756 7 490006 6505756 7 487426 6504856 8 487396 6504796 8 487276 6504676 8 490786 6505366 9 490786 6505336 9 491176 6505336 9 491176 6505276 9 491236 6505276 9 491236 6505126 9 491266 6505126 9 491266 6504976 9 491236 6504976 9 491236 6504916 9 491206 6504916 9 491206 6504886 9 491176 6504886 9 491176 6504856 9 491086 6504856 9 491086 6504886 9 490996 6504886 9 490996 6504916 9 490966 6504916 9 490966 6504946 9 490936 6504946 9 490936 6505006 9 490876 6505006 9 490876 6505186 9 490846 6505186 9 490846 6505246 9 490726 6505246 9 490726 6505276 9 490696 6505276 9 490696 6505366 9 487906 6505066 10 487906 6505036 10 487936 6505036 10 487936 6505006 10 487966 6505006 10 487966 6504616 10 487906 6504616 10 487906 6504586 10 487846 6504586 10 487846 6504556 10 487756 6504556 10 487756 6504526 10 487606 6504526 10 487606 6504646 10 487636 6504646 10 487636 6504766 10 487666 6504766 10 487666 6504886 10 487726 6504886 10 487726 6504976 10 487756 6504976 10 487756 6505006 10 487786 6505006 10 487786 6505036 10 487816 6505036 10 487816 6505066 10 491416 6504856 11 491326 6504856 11 491326 6505006 11 491416 6505006 11 491386 6504736 12 491266 6504736 12 491266 6504826 12 491386 6504826 12 487456 6504586 13 487456 6504436 13 487366 6504436 13 487366 6504466 13 487306 6504466 13 487306 6504556 13 487336 6504556 13 487336 6504586 13 487396 6504586 13 487396 6504676 13 487486 6504676 13 487486 6504586 13 489226 6504646 14 489226 6504616 14 489256 6504616 14 489256 6504556 14 489286 6504556 14 489286 6504466 14 489106 6504466 14 489106 6504586 14 489136 6504586 14 489136 6504646 14 488296 6504406 15 488296 6504316 15 488206 6504316 15 488206 6504376 15 488176 6504376 15 488176 6504466 15 488206 6504466 15 488206 6504496 15 488236 6504496 15 488236 6504526 15 488326 6504526 15 488326 6504406 15 490666 6504466 16 490666 6504376 16 490696 6504376 16 490696 6504316 16 490756 6504316 16 490756 6504256 16 490786 6504256 16 490786 6504166 16 490696 6504166 16 490696 6504226 16 490576 6504226 16 490576 6504286 16 490546 6504286 16 490546 6504466 16 489346 6503986 17 489346 6504076 17 489406 6504076 17 489406 6504166 17 489526 6504166 17 489526 6504256 17 489496 6504256 17 489496 6504346 17 489586 6504346 17 489586 6504256 17 489646 6504256 17 489646 6504196 17 489706 6504196 17 489706 6504016 17 489676 6504016 17 489676 6503896 17 489586 6503896 17 489586 6503956 17 489496 6503956 17 489496 6503986 17 489346 6503986 17 489346 6503986 17 489346 6503836 17 489376 6503836 17 489376 6503746 17 489346 6503746 17 489346 6503566 17 489256 6503566 17 489256 6503506 17 489226 6503506 17 489226 6503416 17 489196 6503416 17 489196 6503386 17 489076 6503386 17 489076 6503446 17 489046 6503446 17 489046 6503566 17 489016 6503566 17 489016 6503626 17 488986 6503626 17 488986 6503836 17 489106 6503836 17 489106 6504106 17 489076 6504106 17 489076 6504226 17 489196 6504226 17 489196 6504196 17 489226 6504196 17 489226 6504076 17 489256 6504076 17 489256 6503986 17 487936 6504166 18 487936 6504136 18 487966 6504136 18 487966 6504016 18 487846 6504016 18 487846 6504046 18 487816 6504046 18 487816 6504136 18 487846 6504136 18 487846 6504166 18 488596 6504046 19 488596 6503986 19 488626 6503986 19 488626 6503896 19 488596 6503896 19 488596 6503716 19 488506 6503716 19 488506 6503806 19 488476 6503806 19 488476 6503986 19 488506 6503986 19 488506 6504046 19 487396 6503896 20 487486 6503836 20 487516 6503806 20 487126 6503956 20 487216 6503986 20 488296 6503806 21 488296 6503776 21 488326 6503776 21 488326 6503746 21 488356 6503746 21 488356 6503626 21 488236 6503626 21 488236 6503656 21 488206 6503656 21 488206 6503686 21 488146 6503686 21 488146 6503776 21 488176 6503776 21 488176 6503806 21 491146 6503686 22 491146 6503626 22 491176 6503626 22 491176 6503536 22 491146 6503536 22 491146 6503476 22 491026 6503476 22 491026 6503656 22 491056 6503656 22 491056 6503686 22 487816 6503506 23 487816 6503476 23 487846 6503476 23 487846 6503386 23 487936 6503386 23 487936 6503356 23 487966 6503356 23 487966 6503296 23 488026 6503296 23 488026 6503236 23 488086 6503236 23 488086 6503116 23 487936 6503116 23 487936 6503146 23 487846 6503146 23 487846 6503176 23 487816 6503176 23 487816 6503206 23 487786 6503206 23 487786 6503386 23 487696 6503386 23 487696 6503356 23 487606 6503356 23 487606 6503506 23 490036 6503506 24 490036 6503386 24 490096 6503386 24 490096 6503266 24 490066 6503266 24 490066 6503176 24 490096 6503176 24 490096 6503026 24 489976 6503026 24 489976 6503086 24 489946 6503086 24 489946 6503146 24 489916 6503146 24 489916 6503386 24 489946 6503386 24 489946 6503506 24 489496 6503356 25 489406 6503356 25 489406 6503446 25 489496 6503446 25 488386 6503356 26 488386 6503326 26 488416 6503326 26 488416 6503236 26 488326 6503236 26 488326 6503266 26 488296 6503266 26 488296 6503356 26 490726 6503206 27 490636 6503206 27 490636 6503326 27 490726 6503326 27 489496 6503056 28 489406 6503056 28 489406 6503176 28 489526 6503176 28 489526 6503086 28 489496 6503086 28 490726 6503086 29 490726 6502996 29 490756 6502996 29 490756 6502876 29 490666 6502876 29 490666 6502936 29 490636 6502936 29 490636 6503086 29 491176 6502996 30 491086 6502996 30 491086 6503086 30 491176 6503086 30 487786 6503056 31 487786 6503026 31 488116 6503026 31 488116 6502996 31 488266 6502996 31 488266 6502936 31 488626 6502936 31 488626 6502906 31 488806 6502906 31 488806 6502876 31 488836 6502876 31 488836 6502786 31 488806 6502786 31 488806 6502636 31 488776 6502636 31 488776 6502606 31 488686 6502606 31 488686 6502576 31 488656 6502576 31 488656 6502546 31 488506 6502546 31 488506 6502516 31 488476 6502516 31 488476 6502486 31 488416 6502486 31 488416 6502456 31 488356 6502456 31 488356 6502396 31 488296 6502396 31 488296 6502306 31 488326 6502306 31 488326 6502216 31 488416 6502216 31 488416 6502246 31 488446 6502246 31 488446 6502276 31 488476 6502276 31 488476 6502306 31 488506 6502306 31 488506 6502336 31 488536 6502336 31 488536 6502366 31 488566 6502366 31 488566 6502426 31 488596 6502426 31 488596 6502456 31 488656 6502456 31 488656 6502486 31 488806 6502486 31 488806 6502396 31 488776 6502396 31 488776 6502366 31 488746 6502366 31 488746 6502306 31 488686 6502306 31 488686 6502246 31 488626 6502246 31 488626 6502186 31 488536 6502186 31 488536 6502156 31 488506 6502156 31 488506 6502126 31 488476 6502126 31 488476 6502006 31 488416 6502006 31 488416 6501976 31 488386 6501976 31 488386 6501946 31 488326 6501946 31 488326 6501886 31 488296 6501886 31 488296 6501856 31 488266 6501856 31 488266 6501706 31 488206 6501706 31 488206 6501676 31 488176 6501676 31 488176 6501646 31 488086 6501646 31 488086 6501616 31 487996 6501616 31 487996 6501586 31 487876 6501586 31 487876 6501556 31 487786 6501556 31 487786 6501646 31 487756 6501646 31 487756 6501766 31 487726 6501766 31 487726 6501856 31 487756 6501856 31 487756 6501946 31 487816 6501946 31 487816 6502066 31 487786 6502066 31 487786 6502096 31 487666 6502096 31 487666 6502186 31 487606 6502186 31 487606 6502246 31 487576 6502246 31 487576 6502276 31 487546 6502276 31 487546 6502306 31 487516 6502306 31 487516 6502426 31 487456 6502426 31 487456 6502636 31 487486 6502636 31 487486 6502696 31 487546 6502696 31 487546 6502786 31 487516 6502786 31 487516 6502906 31 487546 6502906 31 487546 6502966 31 487606 6502966 31 487606 6502996 31 487636 6502996 31 487636 6503026 31 487666 6503026 31 487666 6503056 31 489466 6502816 32 489466 6502786 32 489496 6502786 32 489496 6502756 32 489526 6502756 32 489526 6502726 32 489586 6502726 32 489586 6502696 32 489616 6502696 32 489616 6502486 32 489586 6502486 32 489586 6502366 32 489616 6502366 32 489616 6502156 32 489586 6502156 32 489586 6502096 32 489556 6502096 32 489556 6501976 32 489586 6501976 32 489586 6501796 32 489556 6501796 32 489556 6501766 32 489436 6501766 32 489436 6501646 32 489406 6501646 32 489406 6501616 32 489316 6501616 32 489316 6501526 32 489196 6501526 32 489196 6501586 32 489106 6501586 32 489106 6501856 32 489166 6501856 32 489166 6502096 32 489226 6502096 32 489226 6502246 32 489166 6502246 32 489166 6502426 32 489196 6502426 32 489196 6502486 32 489226 6502486 32 489226 6502576 32 489256 6502576 32 489256 6502606 32 489286 6502606 32 489286 6502726 32 489316 6502726 32 489316 6502786 32 489376 6502786 32 489376 6502816 32 487276 6502336 33 487276 6502306 33 487306 6502306 33 487306 6502216 33 487216 6502216 33 487216 6502096 33 487126 6502096 33 487126 6502246 33 487156 6502246 33 487156 6502306 33 487186 6502306 33 487186 6502336 33 490126 6501856 34 490036 6501856 34 490036 6501976 34 490186 6501976 34 490186 6501886 34 490126 6501886 34 490756 6501406 35 490666 6501406 35 490666 6501496 35 490756 6501496 35 488116 6501346 36 488116 6501316 36 488146 6501316 36 488146 6501076 36 488116 6501076 36 488116 6501016 36 488056 6501016 36 488056 6500866 36 488086 6500866 36 488086 6500836 36 488116 6500836 36 488116 6500746 36 488146 6500746 36 488146 6500716 36 488236 6500716 36 488236 6500776 36 488296 6500776 36 488296 6500926 36 488386 6500926 36 488386 6500776 36 488356 6500776 36 488356 6500656 36 488326 6500656 36 488326 6500566 36 488356 6500566 36 488356 6500476 36 488236 6500476 36 488236 6500506 36 488146 6500506 36 488146 6500416 36 488206 6500416 36 488206 6500326 36 488116 6500326 36 488116 6500296 36 488086 6500296 36 488086 6500206 36 487996 6500206 36 487996 6500116 36 488026 6500116 36 488026 6500026 36 488056 6500026 36 488056 6499846 36 488116 6499846 36 488116 6499786 36 488146 6499786 36 488146 6499696 36 488176 6499696 36 488176 6499606 36 488056 6499606 36 488056 6499636 36 487966 6499636 36 487966 6499606 36 487876 6499606 36 487876 6499636 36 487846 6499636 36 487846 6499726 36 487816 6499726 36 487816 6499786 36 487786 6499786 36 487786 6499936 36 487846 6499936 36 487846 6500026 36 487726 6500026 36 487726 6499996 36 487636 6499996 36 487636 6500086 36 487666 6500086 36 487666 6500356 36 487636 6500356 36 487636 6500446 36 487756 6500446 36 487756 6500566 36 487786 6500566 36 487786 6500656 36 487816 6500656 36 487816 6500746 36 487846 6500746 36 487846 6500896 36 487816 6500896 36 487816 6501076 36 487846 6501076 36 487846 6501166 36 487906 6501166 36 487906 6501286 36 487996 6501286 36 487996 6501316 36 488026 6501316 36 488026 6501346 36 489226 6501046 37 489136 6501046 37 489136 6501196 37 489226 6501196 37 490666 6500896 38 490576 6500896 38 490576 6501106 38 490636 6501106 38 490636 6501196 38 490726 6501196 38 490726 6501046 38 490696 6501046 38 490696 6501016 38 490666 6501016 38 489646 6500926 39 489646 6500836 39 489676 6500836 39 489676 6500716 39 489556 6500716 39 489556 6500926 39 488986 6500836 40 488986 6500776 40 489046 6500776 40 489046 6500626 40 489106 6500626 40 489106 6500446 40 489016 6500446 40 489016 6500416 40 488986 6500416 40 488986 6500356 40 488896 6500356 40 488896 6500836 40 488356 6500296 41 488356 6500176 41 488386 6500176 41 488386 6500026 41 488266 6500026 41 488266 6500056 41 488206 6500056 41 488206 6500116 41 488176 6500116 41 488176 6500236 41 488206 6500236 41 488206 6500296 41 489226 6500146 42 489136 6500146 42 489136 6500236 42 489226 6500236 42 489226 6499756 43 489046 6499756 43 489046 6499846 43 489106 6499846 43 489106 6499876 43 489136 6499876 43 489136 6499936 43 489226 6499936 43 487486 6499666 44 487396 6499666 44 487396 6499756 44 487486 6499756 44 488386 6499666 45 488386 6499636 45 488416 6499636 45 488416 6499546 45 488386 6499546 45 488386 6499486 45 488296 6499486 45 488296 6499576 45 488266 6499576 45 488266 6499666 45 487936 6499546 46 487936 6499186 46 487906 6499186 46 487906 6499156 46 487876 6499156 46 487876 6499126 46 487816 6499126 46 487816 6499066 46 487786 6499066 46 487786 6498886 46 487636 6498886 46 487636 6499066 46 487606 6499066 46 487606 6499186 46 487576 6499186 46 487576 6499306 46 487696 6499306 46 487696 6499396 46 487606 6499396 46 487606 6499486 46 487786 6499486 46 487786 6499516 46 487846 6499516 46 487846 6499546 46 489286 6499396 47 489166 6499396 47 489166 6499486 47 489286 6499486 47 488296 6499036 48 488296 6498886 48 488446 6498886 48 488446 6498796 48 488506 6498796 48 488506 6498706 48 488446 6498706 48 488446 6498676 48 488386 6498676 48 488386 6498646 48 488356 6498646 48 488356 6498616 48 488116 6498616 48 488116 6498586 48 488056 6498586 48 488056 6498556 48 488026 6498556 48 488026 6498526 48 487876 6498526 48 487876 6498646 48 487996 6498646 48 487996 6498676 48 488026 6498676 48 488026 6498706 48 488116 6498706 48 488116 6498976 48 488146 6498976 48 488146 6499006 48 488176 6499006 48 488176 6499096 48 488236 6499096 48 488236 6499306 48 488266 6499306 48 488266 6499396 48 488386 6499396 48 488386 6499306 48 488356 6499306 48 488356 6499096 48 488326 6499096 48 488326 6499036 48 489886 6499276 49 489766 6499276 49 489766 6499396 49 489886 6499396 49 490156 6499066 50 490156 6499006 50 490186 6499006 50 490186 6498766 50 490156 6498766 50 490096 6498556 50 490096 6498526 50 489976 6498526 50 489976 6498706 50 490066 6498706 50 490066 6498826 50 489766 6498826 50 489766 6498916 50 489736 6498916 50 489736 6499006 50 489766 6499006 50 489766 6499066 50 489976 6499066 50 489976 6499036 50 490066 6499036 50 490066 6499066 50 487756 6498466 51 487756 6498256 51 487666 6498256 51 487666 6498226 51 487636 6498226 51 487636 6498196 51 487516 6498196 51 487516 6498226 51 487486 6498226 51 487486 6498376 51 487396 6498376 51 487396 6498406 51 487336 6498406 51 487336 6498526 51 487576 6498526 51 487576 6498556 51 487816 6498556 51 487816 6498466 51 489316 6498106 52 489226 6498106 52 489226 6498226 52 489316 6498226 52 490066 6497836 53 489976 6497836 53 489976 6497956 53 490066 6497956 53 489436 6497536 54 489346 6497536 54 489346 6497926 54 489466 6497926 54 489466 6497596 54 489436 6497596 54 490726 6497926 55 490726 6497656 55 490756 6497656 55 490756 6497596 55 490816 6497596 55 490816 6497506 55 490786 6497506 55 490786 6497476 55 490696 6497476 55 490696 6497536 55 490666 6497536 55 490666 6497656 55 490636 6497656 55 490636 6497746 55 490606 6497746 55 490606 6497776 55 490576 6497776 55 490576 6497926 55 490156 6497746 56 490156 6497716 56 490186 6497716 56 490186 6497656 56 490216 6497656 56 490216 6497566 56 490336 6497566 56 490336 6497476 56 490306 6497476 56 490306 6497326 56 490246 6497326 56 490246 6497296 56 490096 6497296 56 490096 6497356 56 490066 6497356 56 490066 6497596 56 490036 6497596 56 490036 6497716 56 490066 6497716 56 490066 6497746 56 488026 6497536 57 487936 6497536 57 487936 6497626 57 488026 6497626 57 489466 6497206 58 489346 6497206 58 489346 6497446 58 489376 6497446 58 489376 6497506 58 489526 6497506 58 489526 6497296 58 489466 6497296 58 490876 6497266 59 490786 6497266 59 490786 6497356 59 490876 6497356 59 490936 6497236 60 490936 6497206 60 490996 6497206 60 490996 6497176 60 491026 6497176 60 491026 6496996 60 491086 6496996 60 491086 6496936 60 491206 6496936 60 491206 6496696 60 491116 6496696 60 491116 6496726 60 491086 6496726 60 491086 6496846 60 491056 6496846 60 491056 6496906 60 490996 6496906 60 490996 6496966 60 490936 6496966 60 490936 6497026 60 490906 6497026 60 490906 6497116 60 490876 6497116 60 490876 6497146 60 490846 6497146 60 490846 6497236 60 490366 6496906 61 490276 6496906 61 490276 6497026 61 490306 6497026 61 490306 6497176 61 490396 6497176 61 490396 6497206 61 490516 6497206 61 490516 6497116 61 490456 6497116 61 490456 6497056 61 490396 6497056 61 490396 6497026 61 490366 6497026 61 487456 6497146 62 487486 6497116 62 487486 6497086 62 487546 6497086 62 487546 6496936 62 487216 6497026 62 487216 6497086 62 487126 6497086 62 487126 6497176 62 489586 6496936 63 489376 6496936 63 489376 6497026 63 489586 6497026 63 spatstat.geom/tests/testsS.R0000644000176200001440000002750514611065354015633 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) ## ## tests/segments.R ## Tests of psp class and related code ## [SEE ALSO: tests/xysegment.R] ## ## $Revision: 1.33 $ $Date: 2022/05/22 08:39:47 $ local({ if(ALWAYS) { # depends on platform ## pointed out by Jeff Laake W <- owin() X <- psp(x0=.25,x1=.25,y0=0,y1=1,window=W) X[W] } X <- psp(runif(10),runif(10),runif(10),runif(10), window=owin()) if(FULLTEST) { Z <- as.mask.psp(X) Z <- pixellate(X) } if(ALWAYS) { # platform dependent ## add short segment Shorty <- psp(0.5, 0.6, 0.5001, 0.6001, window=Window(X)) XX <- superimpose(X[1:5], Shorty, X[6:10]) ZZ <- as.mask.psp(XX) ZZ <- pixellate(XX) } if(FULLTEST) { #' misc PX <- periodify(X, 2) } if(ALWAYS) { # C code ## tests of pixellate.psp -> seg2pixL ns <- 50 out <- numeric(ns) for(i in 1:ns) { X <- psp(runif(1), runif(1), runif(1), runif(1), window=owin()) len <- lengths_psp(X) dlen <- sum(pixellate(X)$v) out[i] <- if(len > 1e-7) dlen/len else 1 } if(diff(range(out)) > 0.01) stop(paste( "pixellate.psp test 1: relative error [", paste(diff(range(out)), collapse=", "), "]")) ## Michael Sumner's test examples set.seed(33) n <- 2001 co <- cbind(runif(n), runif(n)) ow <- owin() X <- psp(co[-n,1], co[-n,2], co[-1,1], co[-1,2], window=ow) s1 <- sum(pixellate(X)) s2 <- sum(lengths_psp(X)) if(abs(s1 - s2)/s2 > 0.01) { stop(paste("pixellate.psp test 2:", "sum(pixellate(X)) = ", s1, "!=", s2, "= sum(lengths_psp(X))")) } wts <- 1/(lengths_psp(X) * X$n) s1 <- sum(pixellate(X, weights=wts)) if(abs(s1-1) > 0.01) { stop(paste("pixellate.psp test 3:", "sum(pixellate(X, weights))=", s1, " (should be 1)")) } X <- psp(0, 0, 0.01, 0.001, window=owin()) s1 <- sum(pixellate(X)) s2 <- sum(lengths_psp(X)) if(abs(s1 - s2)/s2 > 0.01) { stop(paste("pixellate.psp test 4:", "sum(pixellate(X)) = ", s1, "!=", s2, "= sum(lengths_psp(X))")) } X <- psp(0, 0, 0.001, 0.001, window=owin()) s1 <- sum(pixellate(X)) s2 <- sum(lengths_psp(X)) if(abs(s1 - s2)/s2 > 0.01) { stop(paste("pixellate.psp test 5:", "sum(pixellate(X)) = ", s1, "!=", s2, "= sum(lengths_psp(X))")) } } if(FULLTEST) { #' cases of superimpose.psp A <- as.psp(matrix(runif(40), 10, 4), window=owin()) B <- as.psp(matrix(runif(40), 10, 4), window=owin()) superimpose(A, B, W=ripras) superimpose(A, B, W="convex") } if(FULLTEST) { #' as.psp.data.frame df <- as.data.frame(matrix(runif(40), ncol=4)) A <- as.psp(df, window=square(1)) colnames(df) <- c("x0","y0","x1","y1") df <- cbind(df, data.frame(marks=1:nrow(df))) B <- as.psp(df, window=square(1)) colnames(df) <- c("xmid", "ymid", "length", "angle", "marks") E <- as.psp(df, window=square(c(-1,2))) G <- E %mark% factor(sample(letters[1:3], nsegments(E), replace=TRUE)) H <- E %mark% runif(nsegments(E)) #' print and summary methods A B E G H summary(B) summary(G) summary(H) M <- B marks(M) <- data.frame(id=marks(B), len=lengths_psp(B)) M summary(M) subset(M, select=len) #' plot method cases spatstat.options(monochrome=TRUE) plot(B) plot(G) plot(M) spatstat.options(monochrome=FALSE) plot(B) plot(G) plot(M) #' misuse of 'col' argument - several cases plot(G, col="grey") # discrete plot(B, col="grey") plot(unmark(B), col="grey") plot(M, col="grey") #' miscellaneous class support cases marks(M) <- marks(M)[1,,drop=FALSE] #' undocumented as.ppp(B) } if(ALWAYS) { # C code #' segment crossing code X <- psp(runif(30),runif(30),runif(30),runif(30), window=owin()) A <- selfcut.psp(X, eps=1e-11) B <- selfcut.psp(X[1]) #' Y <- psp(runif(30),runif(30),runif(30),runif(30), window=owin()) Z <- edges(letterR)[c(FALSE,TRUE)] spatstat.options(selfcrossing.psp.useCall=FALSE, crossing.psp.useCall=FALSE) A <- selfcrossing.psp(X) B <- selfcrossing.psp(Z) D <- crossing.psp(X,Y,details=TRUE) spatstat.options(selfcrossing.psp.useCall=TRUE, crossing.psp.useCall=TRUE) A <- selfcrossing.psp(X) B <- selfcrossing.psp(Z) D <- crossing.psp(X,Y,details=TRUE) reset.spatstat.options() } if(FULLTEST) { #' geometry m <- data.frame(A=1:10, B=letters[1:10]) X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin(), marks=m) Z <- rotate(X, angle=pi/3, centre=c(0.5, 0.5)) Y <- endpoints.psp(X, which="lower") Y <- endpoints.psp(X, which="upper") Y <- endpoints.psp(X, which="right") U <- flipxy(X) } if(ALWAYS) { ## nnfun.psp P <- psp(runif(10), runif(10), runif(10), runif(10), window=square(1), marks=runif(10)) f <- nnfun(P) f <- nnfun(P, value="mark") d <- domain(f) Z <- as.im(f) } }) reset.spatstat.options() #' #' tests/simplepan.R #' #' Tests of user interaction in simplepanel #' Handled by spatstatLocator() #' #' $Revision: 1.3 $ $Date: 2020/05/01 09:59:59 $ #' if(ALWAYS) { # may depend on platform local({ ## Adapted from example(simplepanel) ## make boxes outerbox <- owin(c(0,4), c(0,1)) buttonboxes <- layout.boxes(outerbox, 4, horizontal=TRUE, aspect=1) ## make environment containing an integer count myenv <- new.env() assign("answer", 0, envir=myenv) ## what to do when finished: return the count. myexit <- function(e) { return(get("answer", envir=e)) } ## button clicks ## decrement the count Cminus <- function(e, xy) { ans <- get("answer", envir=e) assign("answer", ans - 1, envir=e) return(TRUE) } ## display the count (clicking does nothing) Cvalue <- function(...) { TRUE } ## increment the count Cplus <- function(e, xy) { ans <- get("answer", envir=e) assign("answer", ans + 1, envir=e) return(TRUE) } ## 'Clear' button Cclear <- function(e, xy) { assign("answer", 0, envir=e) return(TRUE) } ## quit button Cdone <- function(e, xy) { return(FALSE) } myclicks <- list("-"=Cminus, value=Cvalue, "+"=Cplus, done=Cdone) ## redraw the button that displays the current value of the count Rvalue <- function(button, nam, e) { plot(button, add=TRUE) ans <- get("answer", envir=e) text(centroid.owin(button), labels=ans) return(TRUE) } ## make the panel P <- simplepanel("Counter", B=outerbox, boxes=buttonboxes, clicks=myclicks, redraws = list(NULL, Rvalue, NULL, NULL), exit=myexit, env=myenv) ## queue up a sequence of inputs boxcentres <- do.call(concatxy, unname(lapply(buttonboxes[c(3,3,1,3,2,4)], centroid.owin))) spatstat.utils::queueSpatstatLocator(boxcentres$x, boxcentres$y) ## go run.simplepanel(P) }) } # # tests/splitpea.R # # Check behaviour of split.ppp etc # # Thanks to Marcelino de la Cruz # # $Revision: 1.17 $ $Date: 2021/04/15 06:19:51 $ # local({ W <- square(8) X <- ppp(c(2.98, 4.58, 7.27, 1.61, 7.19), c(7.56, 5.29, 5.03, 0.49, 1.65), window=W, check=FALSE) Z <- quadrats(W, 4, 4) Yall <- split(X, Z, drop=FALSE) Ydrop <- split(X, Z, drop=TRUE) if(ALWAYS) { # may depend on platform P <- Yall[[1]] if(!all(inside.owin(P$x, P$y, P$window))) stop("Black hole detected when drop=FALSE") P <- Ydrop[[1]] if(!all(inside.owin(P$x, P$y, P$window))) stop("Black hole detected when drop=TRUE") Ydrop[[1]] <- P[1] split(X, Z, drop=TRUE) <- Ydrop } ## test NA handling Zbad <- quadrats(square(4), 2, 2) Ybdrop <- split(X, Zbad, drop=TRUE) Yball <- split(X, Zbad, drop=FALSE) if(FULLTEST) { ## other bugs/ code blocks in split.ppp, split<-.ppp, [<-.splitppp flog <- rep(c(TRUE,FALSE), 21) fimg <- as.im(dirichlet(runifrect(5, Window(cells))), dimyx=32) A <- split(cells, flog) B <- split(cells, square(0.5)) D <- split(cells, fimg) E <- split(cells, logical(42), drop=TRUE) Cellules <- cells split(Cellules, flog) <- solapply(A, rjitter) split(Cellules, fimg) <- solapply(D, rjitter) D[[2]] <- rjitter(D[[2]]) Funpines <- finpines marks(Funpines)[,"diameter"] <- factor(marks(Funpines)[,"diameter"]) G <- split(Funpines) H <- split(Funpines, "diameter") split(Funpines) <- solapply(G, rjitter) split(Funpines, "diameter") <- solapply(H, rjitter) ## From Marcelino set.seed(1) W<- square(10) # the big window ## puntos<- rpoispp(0.5, win=W) puntos<- runifrect(rpois(1, 0.5 * area(W)), win=W) r00 <- letterR r05 <- shift(letterR,c(0,5)) r50 <- shift(letterR,c(5,0)) r55 <- shift(letterR,c(5,5)) tessr4 <- tess(tiles=list(r00, r05,r50,r55)) puntosr4 <- split(puntos, tessr4, drop=TRUE) split(puntos, tessr4, drop=TRUE) <- puntosr4 ## More headaches with mark format A <- runifrect(10) B <- runifrect(10) AB <- split(superimpose(A=A, B=B)) #' check that split<- respects ordering where possible X <- amacrine Y <- split(X) split(X) <- Y stopifnot(identical(X, amacrine)) #' split.ppx df <- data.frame(x=runif(4),y=runif(4),t=runif(4), age=rep(c("old", "new"), 2), mineral=factor(rep(c("Au","Cu"), each=2), levels=c("Au", "Cu", "Pb")), size=runif(4)) X <- ppx(data=df, coord.type=c("s","s","t","m", "m","m")) Y <- split(X, "age") Y <- split(X, "mineral", drop=TRUE) Y <- split(X, "mineral") print(Y) print(summary(Y)) Y[c(TRUE,FALSE,TRUE)] Y[1:2] Y[3] <- Y[1] } }) ## ## tests/symbolmaps.R ## ## Quirks associated with symbolmaps, etc. ## ## $Revision: 1.6 $ $Date: 2024/04/08 04:22:25 $ if(FULLTEST) { local({ set.seed(100) X <- runifrect(8) ## symbolmap for numeric values g1 <- symbolmap(range=c(0,100), size=function(x) x/50) invoke.symbolmap(g1, 50, x=numeric(0), y=numeric(0), add=TRUE) plot(g1, labelmap=100) ## symbolmap for discrete categories g2 <- symbolmap(inputs=letters[1:5], chars=1:5) invoke.symbolmap(g2, "a", x=numeric(0), y=numeric(0), add=TRUE) plot(g2) ## constant/trivial a <- symbolmap(pch=16) print(a) plot(a) symbolmapdomain(a) b <- symbolmap() print(b) ## graphical arguments with mixed types (function, constant) f <- function(x) { ifelse(x %in% letters[1:3], "circles", "squares")} g3 <- symbolmap(inputs=letters[1:5], size=0.7, shape=f) invoke.symbolmap(g3, "a", x=numeric(0), y=numeric(0), add=TRUE) plot(g3) ## textureplot V <- as.im(dirichlet(X)) tmap <- textureplot(V) textureplot(V, textures=tmap, legend=TRUE, leg.side="left") textureplot(V, leg.side="bottom") textureplot(V, leg.side="top") ## spacing too large for tiles - upsets various pieces of code textureplot(V, spacing=2) ## plot.texturemap plot(tmap, vertical=TRUE) plot(tmap, vertical=TRUE, xlim=c(0,1)) plot(tmap, vertical=TRUE, ylim=c(0,1)) plot(tmap, vertical=FALSE, xlim=c(0,1)) plot(tmap, vertical=FALSE, ylim=c(0,1)) ## infrastructure plan.legend.layout(owin(), side="top", started=TRUE) }) } spatstat.geom/tests/testsQ.R0000644000176200001440000000645214611065354015627 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' #' tests/quadschemes.R #' #' Quadrature schemes, dummy points etc #' #' $Revision: 1.8 $ $Date: 2020/12/04 04:56:26 $ #' if(FULLTEST) { local({ ## class 'quad' qu <- quadscheme(cells) qm <- quadscheme(amacrine) plot(qu) plot(qm) is.multitype(qu) is.multitype(qm) a <- param.quad(qu) a <- param.quad(qm) a <- equals.quad(qu) a <- equals.quad(qm) a <- domain(qu) unitname(qu) <- c("Furlong", "Furlongs") ## utilities b <- cellmiddles(square(1), 3, 4) b <- cellmiddles(letterR, 3, 4, distances=FALSE) b <- cellmiddles(letterR, 3, 4, distances=TRUE) v <- tilecentroids(square(1), 3, 4) v <- tilecentroids(letterR, 3, 4) n <- default.n.tiling(cells) n <- default.n.tiling(cells, nd=4) n <- default.n.tiling(cells, ntile=4) n <- default.n.tiling(cells, ntile=4, quasi=TRUE) ## quadrature weights - special cases ## X <- runifpoint(10, as.mask(letterR)) X <- runifrect(10, Frame(letterR))[as.mask(letterR)] gr <- gridweights(X, ntile=12, npix=7) # causes warnings about zero digital area ## plot.quad plot(quadscheme(cells, method="dirichlet", nd=7), tiles=TRUE) plot(quadscheme(cells, method="dirichlet", nd=7, exact=FALSE), tiles=TRUE) ## logistic d <- quadscheme.logi(cells, logi.dummy(cells, "binomial")) print(summary(d)) d <- quadscheme.logi(cells, logi.dummy(cells, "poisson")) print(summary(d)) d <- quadscheme.logi(cells, logi.dummy(cells, "grid")) print(summary(d)) d <- quadscheme.logi(cells, logi.dummy(cells, "transgrid")) print(summary(d)) d <- quadscheme.logi(amacrine, logi.dummy(amacrine, "binomial", mark.repeat=TRUE)) print(summary(d)) d <- quadscheme.logi(amacrine, logi.dummy(amacrine, "poisson", mark.repeat=FALSE)) print(summary(d)) }) } # # tests/quadcount.R # # Tests of quadrat counting code # # $Revision: 1.3 $ $Date: 2023/08/15 13:28:31 $ local({ if(FULLTEST) { ## from Jordan Adamson Te <- quadrats(unit.square(), 4) X <- runifrect(8) Q <- quadratcount(X, tess=Te) ## from M. Gimond A <- quadratcount(humberside, 2, 3) nA <- as.integer(t(A)) if(!all(nA == c(2, 20, 13, 11, 34, 123))) stop("Incorrect quadrat count (2,3)") ## execute intensity.quadratcount lamA <- intensity(A, image=TRUE) ## check sum 1/lambda equals area vA <- sum(1/lamA[humberside]) aA <- area(Window(humberside)) if(abs(1 - vA/aA) > 0.05) stop("Incorrect sum of 1/lambda (2,3)") ## B <- quadratcount(humberside, 5, 3) nB <- as.integer(t(B)) if(!all(nB == c(0, 0, 3, 19, 3, 2, 14, 5, 0, 2, 117, 35, 3))) stop("Incorrect quadrat count (5,3)") lamB <- intensity(B, image=TRUE) vB <- sum(1/lamB[humberside]) aaB <- tile.areas(as.tess(B)) aB <- sum(aaB[nB > 0]) if(abs(1 - vB/aB) > 0.05) stop("Incorrect sum of 1/lambda (5,3)") } }) reset.spatstat.options() spatstat.geom/tests/testsAtoC.R0000644000176200001440000003351614611065354016256 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) ## badwindowcheck.R ## $Revision: 1.3 $ $Date: 2020/04/28 12:58:26 $ ## local({ if(ALWAYS) { ## Simple example of self-crossing polygon x <- read.table("selfcross.txt", header=TRUE) ## Auto-repair w <- owin(poly=x) ## Real data involving various quirks b <- read.table("badwindow.txt", header=TRUE) b <- split(b, factor(b$i)) b <- lapply(b, function(z) { as.list(z[,-3]) }) ## make owin without checking W <- owin(poly=b, check=FALSE, fix=FALSE) ## Apply stringent checks owinpolycheck(W,verbose=FALSE) ## Auto-repair W2 <- owin(poly=b) } }) ## tests/closeshave.R ## check 'closepairs/crosspairs' code ## validity and memory allocation ## $Revision: 1.29 $ $Date: 2022/06/06 10:09:56 $ ## ------- All this code must be run on every hardware ------- local({ r <- 0.12 close.all <- closepairs(redwood, r) close.ij <- closepairs(redwood, r, what="indices") close.ijd <- closepairs(redwood, r, what="ijd") close.every <- closepairs(redwood, r, what="all", distinct=FALSE) ## test agreement stopifnot(identical(close.ij, close.all[c("i","j")])) stopifnot(identical(close.ijd, close.all[c("i","j","d")])) ## validate basic format of result checkformat <- function(object, callstring) { if(length(unique(lengths(object))) > 1) stop(paste("Result of", callstring, "contains vectors with different lengths")) return(invisible(TRUE)) } checkformat(close.all, "closepairs(redwood, r)") checkformat(close.ij, "closepairs(redwood, r, what='indices')") checkformat(close.ijd, "closepairs(redwood, r, what='ijd')") checkformat(close.every, "closepairs(redwood, r, what='all', distinct=FALSE)") #' test memory overflow code close.cigar <- closepairs(redwood, r, what="ijd", nsize=2) close.cigar <- closepairs(redwood, r, what="ijd", nsize=2, periodic=TRUE) #' test special cases onepoint <- redwood[1] checkformat(closepairs(onepoint, r), "closepairs(onepoint, r)") checkformat(closepairs(onepoint, r, what="indices"), "closepairs(onepoint, r, what='indices')") checkformat(closepairs(onepoint, r, what="ijd"), "closepairs(onepoint, r, what='ijd')") checkformat(closepairs(onepoint, r, what="all", distinct=FALSE), "closepairs(onepoint, r, what='all', distinct=FALSE)") #' .............. crosspairs .................................. Y <- split(amacrine) on <- Y$on off <- Y$off cross.all <- crosspairs(on, off, r) cross.ij <- crosspairs(on, off, r, what="indices") cross.ijd <- crosspairs(on, off, r, what="ijd") cross.every <- crosspairs(on, off, r, what="all", distinct=FALSE) cross.period <- crosspairs(on, off, r, periodic=TRUE) cross.exclude <- crosspairs(cells, cells[1:32], 0.1, iX=1:42, iY=1:32) ## validate basic format checkformat(cross.all, "crosspairs(on, off, r)") checkformat(cross.ij, "crosspairs(on, off, r, what='indices')") checkformat(cross.ijd, "crosspairs(on, off, r, what='ijd')") checkformat(cross.every, "crosspairs(on, off, r, what='all', distinct=FALSE)") checkformat(cross.period, "crosspairs(on, off, r, periodic=TRUE)") checkformat(cross.exclude, "crosspairs(cells, cells[], r, iX, iY)") ## test agreement stopifnot(identical(cross.ij, cross.all[c("i","j")])) stopifnot(identical(cross.ijd, cross.all[c("i","j","d")])) # closethresh vs closepairs: EXACT agreement thresh <- 0.08 clt <- closethresh(redwood, r, thresh) cl <- with(closepairs(redwood, r), list(i=i, j=j, th = (d <= thresh))) if(!identical(cl, clt)) stop("closepairs and closethresh disagree") reordered <- function(a) { o <- with(a, order(i,j)) as.list(as.data.frame(a)[o,,drop=FALSE]) } samesame <- function(a, b) { identical(reordered(a), reordered(b)) } ## ............................................... #' compare with older, slower code op <- spatstat.options(closepairs.newcode=FALSE, closepairs.altcode=FALSE, crosspairs.newcode=FALSE) ## ............................................... old.close.ij <- closepairs(redwood, r, what="indices") old.cross.ij <- crosspairs(on, off, r, what="indices") stopifnot(samesame(close.ij, old.close.ij)) stopifnot(samesame(cross.ij, old.cross.ij)) # execute only: old.close.every <- closepairs(redwood, r, what="all", distinct=FALSE) old.close.once <- closepairs(redwood, r, what="all", twice=FALSE) #' test memory overflow code old.close.cigar <- closepairs(redwood, r, what="ijd", nsize=2) old.close.cigar <- closepairs(redwood, r, what="ijd", nsize=2, periodic=TRUE) ## ............................................... spatstat.options(op) ## ............................................... ## ............................................... #' alternative code - execution only op <- spatstat.options(closepairs.newcode=FALSE, closepairs.altcode=TRUE) alt.close.ij <- closepairs(redwood, r, what="indices") alt.close.ijd <- closepairs(redwood, r, what="ijd") alt.close.all <- closepairs(redwood, r, what="all") #' test memory overflow code alt.close.cigar <- closepairs(redwood, r, what="ijd", nsize=2) alt.close.cigar <- closepairs(redwood, r, what="ijd", nsize=2, periodic=TRUE) spatstat.options(op) ## ............................................... # Rasmus' example R <- 0.04 U <- as.ppp(gridcenters(owin(), 50, 50), W=owin()) cp <- crosspairs(U, U, R) G <- matrix(0, npoints(U), npoints(U)) G[cbind(cp$i, cp$j)] <- 1 if(!isSymmetric(G)) stop("crosspairs is not symmetric in Rasmus example") #' periodic distance pclose <- function(X, R, method=c("raw", "C")) { method <- match.arg(method) switch(method, raw = { D <- pairdist(X, periodic=TRUE) diag(D) <- Inf result <- which(D <= R, arr.ind=TRUE) }, C = { result <- closepairs(X, R, periodic=TRUE, what="indices") }) result <- as.data.frame(result) colnames(result) <- c("i","j") return(result) } #' pick a threshold value which avoids GCC bug 323 RR <- 0.193 A <- pclose(redwood, RR, "raw") B <- pclose(redwood, RR, "C") if(!samesame(A,B)) stop("closepairs.ppp(periodic=TRUE) gives wrong answer") #' other functions that don't have a help file niets <- crosspairquad(quadscheme(cells), 0.1) #' other code blocks u <- closepairs(cells, 0.09, periodic=TRUE, what="all") v <- closepairs(cells, 0.07, twice=FALSE, neat=TRUE) #' tight cluster - guess count does not work Xc <- runifrect(100, square(0.01)) Window(Xc) <- square(1) z <- closepairs(Xc, 0.02, what="indices", distinct=FALSE) z <- closepairs(Xc, 0.02, what="ijd", distinct=FALSE) z <- closepairs(Xc, 0.02, what="all", distinct=FALSE) #' same task, older code aop <- spatstat.options(closepairs.newcode=FALSE) z <- closepairs(Xc, 0.02, what="indices", distinct=FALSE) z <- closepairs(Xc, 0.02, what="ijd", distinct=FALSE) z <- closepairs(Xc, 0.02, what="all", distinct=FALSE) spatstat.options(aop) #' experimental r <- 0.08 a <- closepairs(redwood, r) b <- tweak.closepairs(a, r, 26, 0.1, 0.1) }) local({ #' Three-dimensional ## X <- runifpoint3(100) X <- pp3(runif(100), runif(100), runif(100), box3(c(0,1))) cl <- closepairs(X, 0.2, what="indices") cl <- closepairs(X, 0.2, what="ijd") cl <- closepairs(X, 0.2, distinct=FALSE) cl <- closepairs(X, 0.2, distinct=FALSE, what="indices") cl <- closepairs(X, 0.2, distinct=FALSE, what="ijd") cl <- closepairs(X, 0.2, twice=FALSE, neat=TRUE) #' Test memory overflow code cl <- closepairs(X, 0.2, what="ijd", nsize=2) #' trap obsolete usage cl <- closepairs(X, 0.2, ordered=FALSE) #' crosspairs ## Y <- runifpoint3(100) Y <- pp3(runif(100), runif(100), runif(100), box3(c(0,1))) cr <- crosspairs(X, Y, 0.2, what="indices") cr <- crosspairs(X, Y, 0.2, what="ijd") #' Test memory overflow code cr <- crosspairs(X, Y, 0.2, what="ijd", nsize=2) #' experimental rr <- 0.2 cl <- closepairs(X, rr) ii <- cl$i[[1]] xl <- tweak.closepairs(cl, rr, ii, 0.05, -0.05, 0.05) }) reset.spatstat.options() #' #' tests/cluck.R #' #' Tests of "click*" functions #' using queueing feature of spatstatLocator #' #' $Revision: 1.8 $ $Date: 2022/10/23 00:45:36 $ local({ #' clickppp if(ALWAYS) { spatstat.utils::queueSpatstatLocator(runif(5), runif(5)) XA <- clickppp(hook=square(0.5)) } if(FULLTEST) { spatstat.utils::queueSpatstatLocator(runif(6), runif(6)) XB <- clickppp(n=3, types=c("a", "b")) } if(ALWAYS) { #' clickbox spatstat.utils::queueSpatstatLocator(runif(2), runif(2)) BB <- clickbox() #' clickdist spatstat.utils::queueSpatstatLocator(runif(2), runif(2)) dd <- clickdist() #' clickpoly hex <- vertices(disc(radius=0.4, centre=c(0.5, 0.5), npoly=6)) spatstat.utils::queueSpatstatLocator(hex) PA <- clickpoly() } if(FULLTEST) { holy <- vertices(disc(radius=0.2, centre=c(0.5, 0.5), npoly=6)) holy <- lapply(holy, rev) spatstat.utils::queueSpatstatLocator(concatxy(hex, holy)) PB <- clickpoly(np=2, nv=6) } if(ALWAYS) { #' identify.psp E <- edges(letterR)[c(FALSE, TRUE)] Z <- ppp(c(2.86, 3.65, 3.15), c(1.69, 1.98, 2.56), window=Frame(letterR)) spatstat.utils::queueSpatstatLocator(Z) identify(E) } }) ## tests/colour.R ## ## Colour value manipulation and colour maps ## ## $Revision: 1.10 $ $Date: 2022/10/23 00:37:44 $ ## local({ if(FULLTEST) { f <- function(n) grey(seq(0,1,length=n)) z <- to.grey(f) h <- colourmap(rainbow(9), range=c(0.01, 0.1)) plot(h, labelmap=100) } if(ALWAYS) { a <- colourmap(rainbow(12), range=as.Date(c("2018-01-01", "2018-12-31"))) print(a) print(summary(a)) a(as.Date("2018-06-15")) g <- colourmap(rainbow(4), breaks=as.Date(c("2018-01-01", "2018-04-01", "2018-07-01", "2018-10-01", "2018-12-31"))) print(g) print(summary(g)) g(as.Date("2018-06-15")) } if(FULLTEST) { b <- colourmap(rainbow(12), inputs=month.name) print(b) print(summary(b)) to.grey(b) to.grey(b, transparent=TRUE) plot(b, vertical=FALSE) plot(b, vertical=TRUE) plot(b, vertical=FALSE, gap=0) plot(b, vertical=TRUE, gap=0) plot(b, vertical=FALSE, xlim=c(0, 2)) plot(b, vertical=TRUE, xlim=c(0,2)) plot(b, vertical=FALSE, ylim=c(0, 2)) plot(b, vertical=TRUE, ylim=c(0,2)) argh <- list(a="iets", e="niets", col=b, f=42) arr <- col.args.to.grey(argh) rrgh <- col.args.to.grey(argh, transparent=TRUE) } if(ALWAYS) { #' constant colour map colourmap("grey", range=c(0.01, 0.1)) colourmap("grey", range=as.Date(c("2018-01-01", "2018-12-31"))) colourmap("grey", breaks=as.Date(c("2018-01-01", "2018-04-01", "2018-07-01", "2018-10-01", "2018-12-31"))) colourmap("grey", inputs=month.name) } if(FULLTEST) { #' empty colour map niets <- lut() print(niets) summary(niets) niets <- colourmap() print(niets) summary(niets) plot(niets) } if(FULLTEST) { #' interpolation - of transparent colours co <- colourmap(inputs=c(0, 0.5, 1), rgb(red=c(1,0,0), green=c(0,1,0), blue=c(0,0,1), alpha=c(0.3, 0.6, 0.9))) tco <- interp.colourmap(co) } }) # tests/correctC.R # check for agreement between C and interpreted code # for interpoint distances etc. # $Revision: 1.10 $ $Date: 2023/12/08 07:10:34 $ if(ALWAYS) { # depends on hardware local({ eps <- .Machine$double.eps * 4 checkagree <- function(A, B, blurb) { maxerr <- max(abs(A-B)) cat("Discrepancy", maxerr, "for", blurb, fill=TRUE) if(maxerr > eps) stop(paste("Algorithms for", blurb, "disagree")) return(TRUE) } ## pairdist.ppp set.seed(190901) ## X <- rpoispp(42) X <- runifrect(max(2, rpois(1, 42))) dC <- pairdist(X, method="C") dR <- pairdist(X, method="interpreted") checkagree(dC, dR, "pairdist()") dCp <- pairdist(X, periodic=TRUE, method="C") dRp <- pairdist(X, periodic=TRUE, method="interpreted") checkagree(dCp, dRp, "pairdist(periodic=TRUE)") dCp2 <- pairdist(X, periodic=TRUE, squared=TRUE, method="C") dRp2 <- pairdist(X, periodic=TRUE, squared=TRUE, method="interpreted") checkagree(dCp2, dRp2, "pairdist(periodic=TRUE, squared=TRUE)") ## crossdist.ppp ## Y <- rpoispp(42) Y <- runifrect(max(2, rpois(1, 42))) dC <- crossdist(X, Y, method="C") dR <- crossdist(X, Y, method="interpreted") checkagree(dC, dR, "crossdist()") dC <- crossdist(X, Y, periodic=TRUE, method="C") dR <- crossdist(X, Y, periodic=TRUE, method="interpreted") checkagree(dC, dR, "crossdist(periodic=TRUE)") dC2 <- crossdist(X, Y, periodic=TRUE, squared=TRUE, method="C") dR2 <- crossdist(X, Y, periodic=TRUE, squared=TRUE, method="interpreted") checkagree(dC2, dR2, "crossdist(periodic=TRUE, squared=TRUE)") # nndist.ppp nnC <- nndist(X, method="C") nnI <- nndist(X, method="interpreted") checkagree(nnC, nnI, "nndist()") nn3C <- nndist(X, k=3, method="C") nn3I <- nndist(X, k=3, method="interpreted") checkagree(nn3C, nn3I, "nndist(k=3)") # nnwhich.ppp nwC <- nnwhich(X, method="C") nwI <- nnwhich(X, method="interpreted") checkagree(nwC, nwI, "nnwhich()") nw3C <- nnwhich(X, k=3, method="C") nw3I <- nnwhich(X, k=3, method="interpreted") checkagree(nw3C, nw3I, "nnwhich(k=3)") }) } spatstat.geom/tests/testsUtoZ.R0000644000176200001440000001577314611065354016336 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) # # tests/utils.R # # Tests of miscellaneous utilities # # $Revision: 1.1 $ $Date: 2023/05/07 08:59:32 $ local({ if(FULLTEST) { ## test code blocks in 'progressreport' pstate <- list() for(i in 1:10) { Sys.sleep(1) pstate <- progressreport(i, 10, formula = (time ~ i + I(i^2) + I(i^3)), showtime=TRUE, savehistory=TRUE, state=pstate) } } }) # # tests/windows.R # # Tests of owin geometry code # # $Revision: 1.18 $ $Date: 2023/07/11 06:21:37 $ local({ if(ALWAYS) { # C code ## Ege Rubak spotted this problem in 1.28-1 A <- as.owin(ants) B <- dilation(A, 140) if(!is.subset.owin(A, B)) stop("is.subset.owin fails in polygonal case") ## thanks to Tom Rosenbaum A <- shift(square(3), origin="midpoint") B <- shift(square(1), origin="midpoint") AB <- setminus.owin(A, B) D <- shift(square(2), origin="midpoint") if(is.subset.owin(D,AB)) stop("is.subset.owin fails for polygons with holes") ## thanks to Brian Ripley / SpatialVx M <- as.mask(letterR) stopifnot(area(bdry.mask(M)) > 0) stopifnot(area(convexhull(M)) > 0) R <- as.mask(square(1)) stopifnot(area(bdry.mask(R)) > 0) stopifnot(area(convexhull(R)) > 0) } if(FULLTEST) { RR <- convexify(as.mask(letterR)) CC <- covering(letterR, 0.05, eps=0.1) #' as.owin.data.frame V <- as.mask(letterR, eps=0.2) Vdf <- as.data.frame(V) Vnew <- as.owin(Vdf) zz <- mask2df(V) } if(ALWAYS) { # C code RM <- owinpoly2mask(letterR, as.mask(Frame(letterR)), check=TRUE) } if(FULLTEST) { #' as.owin U <- as.owin(quadscheme(cells)) U2 <- as.owin(list(xmin=0, xmax=1, ymin=0, ymax=1)) } if(ALWAYS) { #' validity of as.mask applied to rectangles with additional raster info Z <- as.im(unit.square()) R <- square(0.5) aR <- area(R) a <- area(as.mask(R, xy=Z)) if(abs(a-aR) > aR/20) stop("Problem with as.mask(rectangle, xy=image)") a <- area(as.mask(R, xy=list(x=Z$xcol, y=Z$yrow))) if(abs(a-aR) > aR/20) stop("Problem with as.mask(rectangle, xy=list(x,y))") } if(FULLTEST) { #' intersections involving masks B1 <- square(1) B2 <- as.mask(shift(B1, c(0.2, 0.3))) o12 <- overlap.owin(B1, B2) o21 <- overlap.owin(B2, B1) i12 <- intersect.owin(B1, B2, eps=0.01) i21 <- intersect.owin(B2, B1, eps=0.01) E2 <- emptywindow(square(2)) e12 <- intersect.owin(B1, E2) e21 <- intersect.owin(E2, B1) #' geometry inradius(B1) inradius(B2) inradius(letterR) inpoint(B1) inpoint(B2) inpoint(letterR) is.convex(B1) is.convex(B2) is.convex(letterR) volume(letterR) perimeter(as.mask(letterR)) boundingradius(cells) boundingbox(letterR) boundingbox(letterR, NULL) boundingbox(solist(letterR)) } if(ALWAYS) { # C code spatstat.options(Cbdrymask=FALSE) bb <- bdry.mask(letterR) spatstat.options(Cbdrymask=TRUE) } if(FULLTEST) { X <- longleaf[square(50)] marks(X) <- marks(X)/8 D <- discs(X) D <- discs(X, delta=5, separate=TRUE) } if(ALWAYS) { # C code AD <- dilated.areas(cells, r=0.01 * matrix(1:10, 10,1), constrained=FALSE, exact=FALSE) } if(FULLTEST) { periodify(B1, 2) periodify(union.owin(B1, B2), 2) periodify(letterR, 2) } if(ALWAYS) { #' Ancient bug in inside.owin W5 <- owin(poly=1e5*cbind(c(-1,1,1,-1),c(-1,-1,1,1))) W6 <- owin(poly=1e6*cbind(c(-1,1,1,-1),c(-1,-1,1,1))) i5 <- inside.owin(0,0,W5) i6 <- inside.owin(0,0,W6) if(!i5) stop("Wrong answer from inside.owin") if(i5 != i6) stop("Results from inside.owin are scale-dependent") } if(FULLTEST) { #' miscellaneous utilities thrash <- function(f) { f(letterR) f(Frame(letterR)) f(as.mask(letterR)) } thrash(meanX.owin) thrash(meanY.owin) thrash(intX.owin) thrash(intY.owin) interpretAsOrigin("right", letterR) interpretAsOrigin("bottom", letterR) interpretAsOrigin("bottomright", letterR) interpretAsOrigin("topleft", letterR) interpretAsOrigin("topright", letterR) } if(ALWAYS) { # depends on polyclip A <- break.holes(letterR) B <- break.holes(letterR, splitby="y") plot(letterR, col="blue", use.polypath=FALSE) } if(ALWAYS) { # C code #' mask conversion M <- as.mask(letterR) D2 <- as.data.frame(M) # two-column D3 <- as.data.frame(M, drop=FALSE) # three-column M2 <- as.owin(D2) M3 <- as.owin(D3) W2 <- owin(mask=D2) W3 <- owin(mask=D3) } if(FULLTEST) { #' void/empty cases nix <- nearest.raster.point(numeric(0), numeric(0), M) E <- emptywindow(Frame(letterR)) print(E) #' cases of summary.owin print(summary(E)) # empty print(summary(Window(humberside))) # single polygon #' additional cases of owin() B <- owin(mask=M$m) # no pixel size or coordinate info xy <- as.data.frame(letterR) xxyy <- split(xy[,1:2], xy$id) spatstat.options(checkpolygons=TRUE) H <- owin(poly=xxyy, check=TRUE) } #' Code for/using intersection and union of windows if(FULLTEST) { Empty <- emptywindow(Frame(letterR)) a <- intersect.owin() a <- intersect.owin(Empty) a <- intersect.owin(Empty, letterR) a <- intersect.owin(letterR, Empty) b <- intersect.owin() b <- intersect.owin(Empty) b <- intersect.owin(Empty, letterR) b <- intersect.owin(letterR, Empty) d <- union.owin(as.mask(square(1)), as.mask(square(2))) #' [.owin A <- erosion(letterR, 0.2) Alogi <- as.im(TRUE, W=A) B <- letterR[A] B <- letterR[Alogi] #' miscellaneous D <- convexhull(Alogi) } }) reset.spatstat.options() ## ## tests/xysegment.R ## [SEE ALSO tests/segments.R] ## ## Test weird problems and boundary cases for line segment code ## ## $Version$ $Date: 2022/10/23 01:21:09 $ ## local({ if(FULLTEST) { ## segment of length zero B <- psp(1/2, 1/2, 1/2, 1/2, window=square(1)) BB <- angles.psp(B) A <- runifrect(3) AB <- project2segment(A,B) ## mark inheritance X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) marks(X) <- 1:10 Y <- selfcut.psp(X) marks(X) <- data.frame(A=1:10, B=factor(letters[1:10])) Z <- selfcut.psp(X) #' psp class support S <- unmark(X) marks(S) <- sample(factor(c("A","B")), nobjects(S), replace=TRUE) intensity(S) intensity(S, weights=runif(nsegments(S))) } }) spatstat.geom/tests/testsL.R0000644000176200001440000000212414611065354015612 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' #' tests/layered.R #' #' Tests of 'layered' class #' #' $Revision: 1.2 $ $Date: 2020/04/29 08:55:17 $ #' if(FULLTEST) { local({ D <- distmap(cells) L <- layered(D, cells, plotargs=list(list(ribbon=FALSE), list(pch=16))) #' plot(L, which=2, plotargs=list(list(pch=3))) plot(L, plotargs=list(list(pch=3))) #' W <- as.owin(L) V <- domain(L) #' methods L2 <- L[square(0.5)] Lr <- reflect(L) Lf <- flipxy(L) Ls <- scalardilate(L, 2) La <- shift(L, origin="midpoint") Lo <- rotate(L, pi/3, origin="bottomleft") Lu <- rescale(L, 0.1, "parsec") #' as.layered M <- as.layered(finpines) M2 <- as.layered(split(amacrine)) }) } spatstat.geom/tests/testsGtoJ.R0000644000176200001440000002070514611065354016267 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) # # tests/hyperframe.R # # test "[.hyperframe" etc # # $Revision: 1.11 $ $Date: 2023/02/03 06:17:16 $ # if(FULLTEST) { local({ lambda <- runif(4, min=50, max=100) X <- lapply(as.list(lambda), function(x) { runifrect(rpois(1, x)) }) h <- hyperframe(lambda=lambda, X=X) h$lambda2 <- lambda^2 h[, "lambda3"] <- lambda^3 h[, "Y"] <- X h[, "X"] <- lapply(X, flipxy) h[, c("X", "Y")] <- hyperframe(X=X, Y=X) names(h) <- LETTERS[1:5] print(h) summary(h) str(h) head(h) tail(h) rn <- rownames(h) r.n <- row.names(h) if(!identical(rn, r.n)) stop("rownames and row.names conflict for hyperframes") dn <- dimnames(h) dimnames(h) <- dn dimnames(h)[[2]][2] <- "copacetic" dimnames(h)[[1]][2] <- "second" #' hyperframe with a hyperatom H <- hyperframe(A=runif(3), B=1:3, D=runifrect(10)) H[,3] H[,3,drop=TRUE] #' special cases of [<- H$B <- H[,1] H[2:3,1] <- H[2:3,2] H[2:3,1] <- H[2,2] H[2,1:2] <- H[3,1:2] #' split f <- factor(c("a", "a", "b")) G <- split(H, f) G[["a"]]$B <- 42 split(H, f) <- G #' [[ and [[<- junk <- pyramidal a <- junk[["group"]] junk[["group"]] <- sample(a) a <- junk[[2]] a <- junk[[15,2]] junk[[15,2]] <- "schizoaffective" junk[[15,2]] <- "z" # Warning given. a <- junk[[2]] # The warned-about NA appears as entry 15. junk[[10,1]] <- cells a <- junk[[10,1]] a <- junk[[10,"Neurons"]] }) } # # tests/imageops.R # # $Revision: 1.43 $ $Date: 2023/08/29 01:03:59 $ # if(ALWAYS) { local({ #' Test of case 'CONNECT=24' in src/distmapbin.[ch] #' Distance transform with 24-connected neighbours A <- distmap(heather$coarse, connect=24) }) } if(FULLTEST) { local({ #' cases of 'im' data tab <- table(sample(factor(letters[1:10]), 30, replace=TRUE)) b <- im(tab, xrange=c(0,1), yrange=c(0,10)) b <- update(b) mat <- matrix(sample(0:4, 12, replace=TRUE), 3, 4) a <- im(mat) levels(a$v) <- 0:4 a <- update(a) levels(mat) <- 0:4 b <- im(mat) b <- update(b) D <- as.im(mat, letterR) df <- as.data.frame(D) DD <- as.im(df, step=c(D$xstep, D$ystep)) #' various manipulations AA <- A <- as.im(owin()) BB <- B <- as.im(owin(c(1.1, 1.9), c(0,1))) Z <- imcov(A, B) stopifnot(abs(max(Z) - 0.8) < 0.1) Frame(AA) <- Frame(B) Frame(BB) <- Frame(A) ## handling images with 1 row or column ycov <- function(x, y) y E <- as.im(ycov, owin(), dimyx = c(2,1)) G <- cut(E, 2) H <- as.tess(G) E12 <- as.im(ycov, owin(), dimyx = c(1,2)) G12 <- cut(E12, 2) H12 <- as.tess(G12) AAA <- as.array(AA) EEE <- as.array(E) AAD <- as.double(AA) EED <- as.double(E) aaa <- xtfrm(AAA) eee <- xtfrm(E) ## d <- distmap(cells, dimyx=32) D6 <- (d <= 0.06) Z <- connected(D6, method="interpreted") Z <- connected(D6, connect=4) Z <- connected(D6, method="interpreted", connect=4) a <- where.max(d, first=FALSE) a <- where.min(d, first=FALSE) dx <- raster.x(d) dy <- raster.y(d) dxy <- raster.xy(d) xyZ <- raster.xy(Z, drop=TRUE) horosho <- conform.imagelist(cells, list(d, Z)) #' split.im W <- square(1) X <- as.im(function(x,y){x}, W) Y <- dirichlet(runifrect(7, W)) Z <- split(X, as.im(Y)) ## ........... cases of "[.im" ........................ ## index window has zero overlap area with image window Out <- owin(c(-0.5, 0), c(0,1)) oo <- X[Out] oo <- X[Out, drop=FALSE] if(!is.im(oo)) stop("Wrong format in [.im with disjoint index window") oon <- X[Out, drop=TRUE, rescue=FALSE] if(is.im(oon)) stop("Expected a vector of values, not an image, from [.im") if(!all(is.na(oon))) stop("Expected a vector of NA values in [.im") ## Empty <- cells[FALSE] ff <- d[Empty] gg <- d[2,] gg <- d[,2] gg <- d[j=2] gg <- d[2:4, 3:5] hh <- d[2:4, 3:5, rescue=TRUE] if(!is.im(hh)) stop("rectangle was not rescued in [.im") ## factor and NA values f <- cut(d, breaks=4) f <- f[f != levels(f)[1], drop=FALSE] fff <- f[, , drop=FALSE] fff <- f[cells] fff <- f[cells, drop=FALSE] fff <- f[Empty] ## ........... cases of "[<-.im" ....................... d[,] <- d[] + 1 d[Empty] <- 42 ## smudge() and rasterfilter() dd <- smudge(d) ## rgb/hsv options X <- setcov(owin()) M <- Window(X) Y <- as.im(function(x,y) x, W=M) Z <- as.im(function(x,y) y, W=M) # convert after rescaling RGBscal <- rgbim(X, Y, Z, autoscale=TRUE, maxColorValue=1) HSVscal <- hsvim(X, Y, Z, autoscale=TRUE) #' cases of [.im Ma <- as.mask(M, dimyx=37) ZM <- Z[raster=Ma, drop=FALSE] ZM[solutionset(Y+Z > 0.4)] <- NA ZF <- cut(ZM, breaks=5) ZL <- (ZM > 0) P <- list(x=c(0.511, 0.774, 0.633, 0.248, 0.798), y=c(0.791, 0.608, 0.337, 0.613, 0.819)) zmp <- ZM[P, drop=TRUE] zfp <- ZF[P, drop=TRUE] zlp <- ZL[P, drop=TRUE] P <- as.ppp(P, owin()) zmp <- ZM[P, drop=TRUE] zfp <- ZF[P, drop=TRUE] zlp <- ZL[P, drop=TRUE] #' miscellaneous ZZ <- zapsmall.im(Z, digits=6) ZZ <- zapsmall.im(Z) ZS <- shift(Z, origin="centroid") ZS <- shift(Z, origin="bottomleft") ZA <- affine(Z, mat=diag(c(-1,-2))) U <- scaletointerval(Z) C <- as.im(1, W=U) U <- scaletointerval(C) #' hist.im h <- hist(Z) h <- hist(Z, probability=TRUE) h <- hist(Z, plot=FALSE) Zcut <- cut(Z, breaks=5) h <- hist(Zcut) # barplot hp <- hist(Zcut, probability=TRUE) # barplot plot(h) # plot.barplotdata #' plot.im code blocks plot(Z, ribside="left") plot(Z, ribside="top") plot(Z, riblab="value") plot(Z, clipwin=square(0.5)) plot(Z - mean(Z), log=TRUE) plot(Z, valuesAreColours=TRUE) # rejected with a warning IX <- as.im(function(x,y) { as.integer(round(3*x)) }, square(1)) co <- colourmap(rainbow(4), inputs=0:3) plot(IX, col=co) CX <- eval.im(col2hex(IX+1L)) plot(CX, valuesAreColours=TRUE) plot(CX, valuesAreColours=FALSE) #' plot.im contour code logarithmic case V0 <- setcov(owin()) V2 <- exp(2*V0+1) plot(V2, log=TRUE, addcontour=TRUE, contourargs=list(col="white")) plot(V2, log=TRUE, addcontour=TRUE, contourargs=list(col="white", nlevels=2)) plot(V2, log=TRUE, addcontour=TRUE, contourargs=list(col="white", nlevels=20)) V4 <- exp(4*V0+1) plot(V4, log=TRUE, addcontour=TRUE, contourargs=list(col="white")) plot(V4, log=TRUE, addcontour=TRUE, contourargs=list(col="white", nlevels=2)) plot(V4, log=TRUE, addcontour=TRUE, contourargs=list(col="white", nlevels=20)) #' pairs.im pairs(solist(Z)) pairs(solist(A=Z)) #' handling and plotting of character and factor images Afactor <- as.im(col2hex("green"), letterR, na.replace=col2hex("blue")) Acharacter <- as.im(col2hex("green"), letterR, na.replace=col2hex("blue"), stringsAsFactors=FALSE) plot(Afactor) plot(Acharacter, valuesAreColours=TRUE) print(summary(Afactor)) print(summary(Acharacter)) #' substitute for runifpoint rup <- function(n, W) { runifrect(n, Frame(W))[W] } #' safelookup (including extrapolation case) Z <- as.im(function(x,y) { x - y }, letterR) Zcut <- cut(Z, breaks=4) B <- grow.rectangle(Frame(letterR), 1) X <- superimpose(rup(10, letterR), rup(20, setminus.owin(B, letterR)), vertices(Frame(B)), W=B) a <- safelookup(Z, X) aa <- safelookup(Z, X, factor=100) b <- safelookup(Zcut, X) bb <- safelookup(Zcut, X, factor=100) cc <- lookup.im(Z, X) #' im.apply Z <- im.apply(bei.extra, sd) #' Math.imlist, Ops.imlist, Complex.imlist U <- Z+2i B <- U * (2+1i) print(summary(B)) V <- solist(A=U, B=B) negV <- -V E <- Re(V) negE <- -E }) } if(ALWAYS) { local({ #' check nearest.valid.pixel W <- Window(demopat) set.seed(911911) X <- runifrect(1000, Frame(W))[W] Z <- quantess(W, function(x,y) { x }, 9)$image nearest.valid.pixel(numeric(0), numeric(0), Z) x <- X$x y <- X$y a <- nearest.valid.pixel(x, y, Z, method="interpreted") b <- nearest.valid.pixel(x, y, Z, method="C") if(!isTRUE(all.equal(a,b))) stop("Unequal results in nearest.valid.pixel") if(!identical(a,b)) stop("Equal, but not identical, results in nearest.valid.pixel") }) } spatstat.geom/tests/testsD.R0000644000176200001440000001124314611065354015604 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' #' tests/dominic.R #' #' Additional tests for Dominic Schuhmacher's code #' #' $Revision: 1.5 $ $Date: 2020/12/03 03:23:25 $ if(ALWAYS) { # tests C code local({ X <- runifrect(10) Y <- runifrect(10) d <- pppdist(X, Y, type="ace", show.rprimal=TRUE) a <- matchingdist(d, type="ace") b <- matchingdist(d, type="mat") d2 <- pppdist(X, Y, type="spa", ccode=FALSE) d2 <- pppdist(X, Y, type="spa", ccode=TRUE, auction=FALSE) d3 <- pppdist(X, Y, type="mat", ccode=TRUE, auction=FALSE) d4 <- pppdist(X[FALSE], Y[FALSE], matching=TRUE, type="spa") d4 <- pppdist(X[FALSE], Y[FALSE], matching=FALSE, type="spa") d4 <- pppdist(X[FALSE], Y[FALSE], matching=TRUE, type="ace") d4 <- pppdist(X[FALSE], Y[FALSE], matching=FALSE, type="ace") m <- pppdist.mat(X, Y, q=Inf, cutoff=0.001) m2 <- pppdist.mat(X[FALSE], Y[FALSE], q=Inf, cutoff=0.001) m3 <- pppdist.mat(X[FALSE], Y[FALSE], q=2, cutoff=0.001) }) } #' #' tests/discarea.R #' #' $Revision: 1.3 $ $Date: 2020/04/28 12:58:26 $ #' if(ALWAYS) { local({ u <- c(0.5,0.5) B <- owin(poly=list(x=c(0.3, 0.5, 0.7, 0.4), y=c(0.3, 0.3, 0.6, 0.8))) areaGain(u, cells, 0.1, exact=TRUE) areaGain(u, cells, 0.1, W=NULL) areaGain(u, cells, 0.1, W=B) X <- cells[square(0.4)] areaLoss(X, 0.1, exact=TRUE) # -> areaLoss.diri areaLoss(X, 0.1, exact=FALSE) # -> areaLoss.grid areaLoss.poly(X, 0.1) areaLoss(X, 0.1, exact=FALSE, method="distmap") # -> areaLoss.grid areaLoss(X, c(0.1, 0.15), exact=FALSE, method="distmap") # -> areaLoss.grid }) } #' #' tests/duplicity.R #' #' Tests of duplicated/multiplicity code #' #' $Revision: 1.8 $ $Date: 2020/04/28 12:58:26 $ if(ALWAYS) { local({ X <- ppp(c(1,1,0.5,1), c(2,2,1,2), window=square(3), check=FALSE) Y <- X %mark% factor(letters[c(3,2,4,3)]) ZC <- X %mark% letters[c(3,2,4,3)] ZM <- Y %mark% matrix(c(3,2,4,3), 4, 2) ZD <- Y %mark% as.data.frame(marks(ZM)) #' multiplicity m <- multiplicity(X) mf <- multiplicity(Y) mm <- multiplicity(ZM) mz <- multiplicity(ZD) mc <- multiplicity(ZC) ## default method kk <- c(1,2,3,1,1,2) mk <- multiplicity(kk) ml <- multiplicity(list(sin, cos, tan)[kk]) mc <- multiplicity(c("sin", "cos", "tan")[kk]) if(!identical(ml, mk)) stop("multiplicity.default() disagrees with multiplicityNumeric") if(!identical(mc, mk)) stop("multiplicity() disagrees with multiplicity()") ## data frame method df <- data.frame(x=c(1:4, 1,3,2,4, 0,0, 3,4), y=factor(rep(letters[1:4], 3))) md <- multiplicity(df) ## uniquemap.ppp checkum <- function(X, blurb) { a <- uniquemap(X) if(any(a > seq_along(a))) stop(paste("uniquemap", blurb, "does not respect sequential ordering")) return(invisible(NULL)) } checkum(X, "") checkum(Y, "") checkum(ZC, "") checkum(ZM, "") checkum(ZD, "") ## uniquemap.data.frame dfbase <- as.data.frame(replicate(3, sample(1:20, 10), simplify=FALSE)) df <- dfbase[sample(1:10, 30, replace=TRUE), , drop=FALSE] #' faster algorithm for numeric values checkum(df, "") a <- uniquemap(df) #' general algorithm using 'duplicated' and 'match' dfletters <- as.data.frame(matrix(letters[as.matrix(df)], nrow=nrow(df))) checkum(dfletters, "") b <- uniquemap(dfletters) if(!isTRUE(all.equal(a,b))) stop("inconsistency between algorithms in uniquemap.data.frame") ## uniquemap.matrix M0 <- matrix(1:12, 3, 4) ii <- sample(1:3, 5, replace=TRUE) M4 <- M0[ii, , drop=FALSE] checkum(M4, "") u4 <- uniquemap(M4) C4 <- matrix(letters[M4], 5, 4) uc4 <- uniquemap(C4) checkum(C4, "") if(!isTRUE(all.equal(u4, uc4))) stop("Inconsistency between algorithms in uniquemap.matrix") ## uniquemap.default a <- letters[c(1, 1:4, 3:2)] checkum(a, "") checkum(as.list(a), "") u1 <- uniquemap(a) u2 <- uniquemap(as.list(a)) if(!isTRUE(all.equal(u1, u2))) stop("Inconsistency between algorithms in uniquemap.default") }) } spatstat.geom/tests/testsP1.R0000644000176200001440000000351414611065354015703 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' tests/perspim.R #' #' Check persp.im handling of NA, etc #' #' $Revision: 1.3 $ $Date: 2020/12/04 04:05:54 $ if(FULLTEST) { local({ set.seed(42) Z <- distmap(letterR, invert=TRUE)[letterR, drop=FALSE] X <- runifrect(100, Frame(Z)) M <- persp(Z, colin=Z, visible=TRUE, phi=50) perspPoints(X, Z=Z, M=M) P <- psp(c(2.360, 3.079, 2.211), c(0.934, 1.881, 2.184), c(2.337, 3.654, 3.274), c(1.829, 0.883, 2.093), window=letterR) perspSegments(P, Z=Z, M=M) persp(Z, colmap=rainbow) persp(Z, colmap=beachcolours, sealevel=mean(Z)) persp(Z, colin=as.im(Z, dimyx=dim(Z)/4)) }) } ## ## tests/pixelgripes.R ## Problems related to pixellation of windows ## ## $Revision: 1.8 $ $Date: 2022/10/23 06:21:10 $ if(FULLTEST) { local({ ## pixellate.ppp includes mapping from (x,y) to (row, col) Z <- pixellate(cells, savemap=TRUE) ind <- attr(Z, "map") m <- (as.matrix(Z))[ind] if(!all(m == 1)) stop("Coordinate mismatch in pixellate.ppp") }) } ## ## tests/polygons.R ## ## $Revision: 1.5 $ $Date: 2020/04/30 05:23:52 $ ## if(ALWAYS) { # involves C code local({ co <- as.ppp(corners(letterR), letterR, check=FALSE) co[letterR] b <- letterR$bdry a <- sapply(b, xypolyselfint, yesorno=TRUE) a <- lapply(b, xypolyselfint, proper=TRUE) ## Simple example of self-crossing polygon x <- read.table("selfcross.txt", header=TRUE) y <- xypolyselfint(x) }) } spatstat.geom/tests/testsT.R0000644000176200001440000001112414611065354015622 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' tests/tessera.R #' Tessellation code, not elsewhere tested #' $Revision: 1.9 $ $Date: 2020/12/04 08:04:38 $ #' if(FULLTEST) { local({ W <- owin() Wsub <- square(0.5) X <- runifrect(7, W) A <- dirichlet(X) marks(A) <- 1:nobjects(A) Z <- distmap(letterR, invert=TRUE)[letterR, drop=FALSE] H <- tess(xgrid=0:2, ygrid=0:3) #' discretisation of tiles V <- as.im(A) B <- tess(window=as.mask(W), tiles=tiles(A)) #' logical images D <- tess(image=(Z > 0.2)) U <- (Z > -0.2) # TRUE or NA E <- tess(image=U, keepempty=TRUE) G <- tess(image=U, keepempty=FALSE) #' methods flay <- function(op, ..., Rect=H, Poly=A, Img=E) { a <- do.call(op, list(Rect, ...)) b <- do.call(op, list(Poly, ...)) e <- do.call(op, list(Img, ...)) } flay(reflect) flay(flipxy) flay(shift, vec=c(1,2)) flay(scalardilate, f=2) flay(rotate, angle=pi/3, centre=c(0, 0)) flay(rotate, angle=pi/2) flay(affine, mat=matrix(c(1,2,0,1), 2, 2), vec=c(1,2)) flay(affine, mat=diag(c(1,2))) flay(as.data.frame) ## unitname(A) <- "km" unitname(B) <- c("metre", "metres") unitname(B) print(B) Bsub <- B[c(3,5,7)] print(Bsub) tilenames(H) <- letters[seq_along(tilenames(H))] G <- tess(xgrid=(0:3)/3, ygrid=(0:3)/3) tilenames(G) <- letters[1:9] h <- tilenames(G) GG <- as.tess(tiles(G)) #' Pe <- intersect.tess(A, Wsub, keepmarks=TRUE) Pm <- intersect.tess(A, as.mask(Wsub), keepmarks=TRUE) H <- dirichlet(runifrect(4, W)) AxH <- intersect.tess(A, H, keepmarks=TRUE) # A is marked, H is not HxA <- intersect.tess(H, A, keepmarks=TRUE) # A is marked, H is not b <- bdist.tiles(D) b <- bdist.tiles(A[c(3,5,7)]) #' Eim <- as.im(E, W=letterR) #' #' chop.tess #' horiz/vert lines W <- square(1) H <- infline(h=(2:4)/5) V <- infline(v=(3:4)/5) WH <- chop.tess(W, H) WV <- chop.tess(W, V) #' polygonal tessellation D <- dirichlet(runifrect(4)) DH <- chop.tess(D, H) DV <- chop.tess(D, V) #' image-based tessellation f <- function(x,y){factor(round(4* (x^2 + y^2)))} A <- tess(image=as.im(f, W=W)) L <- infline(p=(1:3)/3, theta=pi/4) AL <- chop.tess(A, L) AH <- chop.tess(A, H) AV <- chop.tess(A, V) #' #' quantess #' quantess.owin a <- quantess(square(1), "x", 3) a <- quantess(square(1), "y", 3) a <- quantess(square(1), "rad", 5, origin=c(1/2, 1/3)) a <- quantess(square(1), "ang", 7, origin=c(1/2, 1/3)) ZFUN <- function(x,y){y-x} a <- quantess(square(1), ZFUN, 3) b <- quantess(letterR, "y", 3) #' quantess.ppp d <- quantess(cells, "y", 4) g <- quantess(demopat, "x", 5) g <- quantess(demopat, "y", 5) g <- quantess(demopat, "rad", 5, origin=c(4442, 4214)) g <- quantess(demopat, "ang", 5, origin=c(4442, 4214)) g <- quantess(demopat, ZFUN, 7) #' quantess.im D <- distmap(demopat) h <- quantess(D, "y", 4) h <- quantess(D, ZFUN, 5) g <- quantess(D, "rad", 5, origin=c(4442, 4214)) g <- quantess(D, "ang", 5, origin=c(4442, 4214)) #' X <- shift(chorley, vec = c(1e6, 0)) tes <- quantess(X, "x", 4) if(anyDuplicated(tilenames(tes))) stop("quantess produced non-unique tilenames") ## ## XR <- runifrect(40, Frame(letterR))[letterR] da <- dirichletAreas(discretise(XR)) }) } #' tests/trigraph.R #' #' Tests for C code in trigraf.c #' #' $Revision: 1.5 $ $Date: 2020/06/12 00:35:44 $ #' if(ALWAYS) { # depends on C code local({ #' called from deldir.R spatstat.deldir.setopt(FALSE, TRUE) A <- delaunay(redwood) spatstat.deldir.setopt(FALSE, FALSE) B <- delaunay(redwood) spatstat.deldir.setopt(TRUE, TRUE) #' called from edges2triangles.R tryangles <- function(iedge, jedge, nt=0) { spatstat.options(fast.trigraph=FALSE) A <- edges2triangles(iedge, jedge) spatstat.options(fast.trigraph=TRUE) B <- edges2triangles(iedge, jedge) if(!all(dim(A) == dim(B)) || !all(A == B)) stop(paste("Discrepancy in edges2triangles (with", nt, "triangles)")) } ## ii <- simplenet$from ## jj <- simplenet$to ii <- c(1, 3, 4, 2, 4, 5, 5, 6, 7, 8) jj <- c(4, 4, 5, 6, 6, 8, 9, 10, 10, 10) tryangles(ii, jj, 0) tryangles(c(ii, 1), c(jj, 5), 1) tryangles(c(ii, 1, 8), c(jj, 5, 9), 2) }) } reset.spatstat.options() spatstat.geom/tests/testsNtoO.R0000644000176200001440000002767614611065354016321 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) # # tests/nndist.R # # Check that nndist and nnwhich give # results consistent with direct calculation from pairdist # # Similarly for nncross and distfun # # Also test whether minnndist(X) == min(nndist(X)) # # $Revision: 1.39 $ $Date: 2021/05/20 09:31:23 $ # local({ eps <- sqrt(.Machine$double.eps) f <- function(mat,k) { apply(mat, 1, function(z,n) { sort(z)[n] }, n=k+1) } g <- function(mat,k) { apply(mat, 1, function(z,n) { order(z)[n] }, n=k+1) } ## ....... Two dimensions ................ if(ALWAYS) { X <- runifrect(24) nn <- nndist(X) nnP <- f(pairdist(X), 1) if(any(abs(nn - nnP) > eps)) stop("nndist.ppp does not agree with pairdist") nn5 <- nndist(X, k=5) nn5P <- f(pairdist(X), 5) if(any(abs(nn5 - nn5P) > eps)) stop("nndist.ppp(k=5) does not agree with pairdist") nw <- nnwhich(X) nwP <- g(pairdist(X), 1) if(any(nw != nwP)) stop("nnwhich.ppp does not agree with pairdist") nw5 <- nnwhich(X, k=5) nw5P <- g(pairdist(X), 5) if(any(nw5 != nw5P)) stop("nnwhich.ppp(k=5) does not agree with pairdist") } if(FULLTEST) { a <- nndist(X, method="test") b <- nnwhich(X, method="test") a <- nndist(X, method="test", k=1:2) b <- nnwhich(X, method="test", k=1:2) a2 <- nndist(cells[1:3], k=1:3) b2 <- nnwhich(cells[1:3], k=1:3) a3 <- nndist(cells[1]) b3 <- nnwhich(cells[1]) m <- factor((1:npoints(X)) %% 2 == 0) a4 <- nndist.default(X, by=m, k=2) b4 <- nnwhich.default(X, by=m, k=2) } if(ALWAYS) { ## nncross.ppp without options Y <- runifrect(30) Y <- Y[nndist(Y) > 0.02] nc <- nncross(X,Y) ncd <- nc$dist ncw <- nc$which cd <- crossdist(X,Y) cdd <- apply(cd, 1, min) cdw <- apply(cd, 1, which.min) if(any(abs(ncd - cdd) > eps)) stop("nncross()$dist does not agree with apply(crossdist(), 1, min)") if(any(ncw != cdw)) stop("nncross()$which does not agree with apply(crossdist(), 1, which.min)") ## nncross with sort on x nc <- nncross(X,Y, sortby="x") ncd <- nc$dist ncw <- nc$which if(any(abs(ncd - cdd) > eps)) stop("nncross(sortby=x)$dist does not agree with apply(crossdist(), 1, min)") if(any(ncw != cdw)) stop("nncross(sortby=x)$which does not agree with apply(crossdist(), 1, which.min)") ## nncross with data pre-sorted on x Y <- Y[order(Y$x)] nc <- nncross(X,Y, is.sorted.Y=TRUE, sortby="x") ncd <- nc$dist ncw <- nc$which cd <- crossdist(X,Y) cdd <- apply(cd, 1, min) cdw <- apply(cd, 1, which.min) if(any(abs(ncd - cdd) > eps)) stop("For sorted data, nncross()$dist does not agree with apply(crossdist(), 1, min)") if(any(ncw != cdw)) stop("For sorted data, nncross()$which does not agree with apply(crossdist(), 1, which.min)") ## sanity check for nncross with k > 1 ndw <- nncross(X, Y, k=1:4, what="which") if(any(is.na(ndw))) stop("NA's returned by nncross.ppp(k > 1, what='which')") nnc4 <- nncross(X, Y, k=1:4) iswhich <- (substr(colnames(nnc4), 1, nchar("which")) == "which") ndw <- nnc4[,iswhich] if(any(is.na(ndw))) stop("NA's returned by nncross.ppp(k > 1)$which") ## test of correctness for nncross with k > 1 flipcells <- flipxy(cells) calcwhich <- nncross(cells, flipcells, k=1:4, what="which") truewhich <- t(apply(crossdist(cells,flipcells), 1, order))[,1:4] if(any(calcwhich != truewhich)) stop("nncross(k > 1) gives wrong answer") } if(FULLTEST) { ## example from Hank Stevens A <- data.frame( m= c("K", "K", "A1", "A2", "G", "A2", "A3"), x=c(4.85, 6.76, 10.58, 19.18, 15.74, 19.08, 12.27), y=c(5.60, 12.92, 11.14, 17.22, 5.74, 1.24, 2.20), stringsAsFactors=TRUE ) X <- with(A, ppp(x, y, marks=m, window=bounding.box.xy(x, y))) suspect <- nncross(X, X[7], iX=1:7, iY=7L)$dist correct <- c(pairdist(X)[1:6, 7], Inf) maxer <- max(abs(suspect[1:6] - correct[1:6])) if(maxer > 0.001) stop("Error in nncross (Inf values) in Hank Stevens example") if(suspect[7] != Inf) stop("Error in nncross (finite values) in Hank Stevens example") M <- as.matrix(minnndist(X, by=marks(X))) M[is.infinite(M)] <- 0 maxer <- max(abs(M - t(M))) if(maxer > 0.001) stop("Error in minnndist(by) in Hank Stevens example") } if(ALWAYS) { #' cover some C code blocks Z <- runifrect(50) X <- Z[1:30] Y <- Z[20:50] iX <- 1:30 iY <- 20:50 Ndw <- nncross(X,Y, iX, iY, k=3) Nw <- nncross(X,Y, iX, iY, k=3, what="which") Nd <- nncross(X,Y, iX, iY, k=3, what="dist") } if(FULLTEST) { ## special cases nndist(X[FALSE]) nndist(X[1]) nndist(X[1:3], k=4) nndist(X[1:3], k=1:4) nnwhich(X[FALSE]) nnwhich(X[1]) nnwhich(X[1:3], k=4) nnwhich(X[1:3], k=1:4) nncross(X[1:3], Y[FALSE]) nncross(X[1:3], Y[1]) nncross(X[1:3], Y[1:3], k=4) nncross(X[1:3], Y[1:3], k=1:4) } ## ....... Three dimensions ................ if(ALWAYS) { rthree <- function(n) { pp3(runif(n), runif(n), runif(n), box3(c(0,1))) } XX <- rthree(42) X <- XX[1:20] nn <- nndist(X) nnP <- f(pairdist(X), 1) if(any(abs(nn - nnP) > eps)) stop("nndist.pp3 does not agree with pairdist") nn5 <- nndist(X, k=5) nn5P <- f(pairdist(X), 5) if(any(abs(nn5 - nn5P) > eps)) stop("nndist.pp3(k=5) does not agree with pairdist") nw <- nnwhich(X) nwP <- g(pairdist(X), 1) if(any(nw != nwP)) stop("nnwhich.pp3 does not agree with pairdist") nw5 <- nnwhich(X, k=5) nw5P <- g(pairdist(X), 5) if(any(nw5 != nw5P)) stop("nnwhich.pp3(k=5) does not agree with pairdist") ff <- function(mat,k) { apply(mat, 1, function(z,n) { sort(z)[n] }, n=k) } gg <- function(mat,k) { apply(mat, 1, function(z,n) { order(z)[n] }, n=k) } Y <- rthree(20) Y <- Y[nndist(Y) > 0.02] DXY <- crossdist(X,Y) a <- nncross(X,Y) a <- nncross(X,Y, what="dist") a <- nncross(X,Y, what="which") if(any(a != gg(DXY, 1))) stop("incorrect result from nncross.pp3(what='which')") a2 <- nncross(X,Y, k=2) a2 <- nncross(X,Y, what="dist", k=2) a2 <- nncross(X,Y, what="which", k=2) if(any(a2 != gg(DXY, 2))) stop("incorrect result from nncross.pp3(k=2, what='which')") } if(FULLTEST) { X <- XX iX <- 1:42 iZ <- 30:42 Z <- X[iZ] b <- nncross(X, Z, iX=iX, iY=iZ) b <- nncross(X, Z, iX=iX, iY=iZ, what="which") b <- nncross(X, Z, iX=iX, iY=iZ, what="dist") b2 <- nncross(X, Z, iX=iX, iY=iZ, k=2) b2 <- nncross(X, Z, iX=iX, iY=iZ, what="which", k=2) b2 <- nncross(X, Z, iX=iX, iY=iZ, what="dist", k=2) e1 <- nncross(X, Y[1:3], k=2:4) c1 <- nncross(X, Y, sortby="var") c2 <- nncross(X, Y, sortby="x") c3 <- nncross(X, Y, sortby="y") c4 <- nncross(X, Y, sortby="z") Xsort <- X[order(coords(X)$x)] c5 <- nncross(Xsort, Y, is.sorted.X=TRUE, sortby="x") Ysort <- Y[order(coords(Y)$x)] c6 <- nncross(Xsort, Ysort, is.sorted.X=TRUE, is.sorted.Y=TRUE, sortby="x") } if(FULLTEST) { ## special cases nndist(X[FALSE]) nndist(X[1]) nndist(X[1:3], k=4) nndist(X[1:3], k=1:4) nnwhich(X[FALSE]) nnwhich(X[1]) nnwhich(X[1:3], k=4) nnwhich(X[1:3], k=1:4) nncross(X[1:3], Y[FALSE]) nncross(X[1:3], Y[1]) nncross(X[1:3], Y[1:3], k=4) nncross(X[1:3], Y[1:3], k=1:4) } ## ....... m dimensions ................ if(ALWAYS) { rx <- function(n) { B <- boxx(c(0,1),c(0,1),c(0,1),c(0,1)) df <- replicate(4, runif(n), simplify=FALSE) names(df) <- letters[23:26] ppx(as.data.frame(df), B) } ## X <- runifpointx(42, B) ## Y <- runifpointx(50, B) X <- rx(42) Y <- rx(50) Y <- Y[nndist(Y) > 0.02] DXY <- crossdist(X,Y) nn <- nndist(X) nnP <- f(pairdist(X), 1) if(any(abs(nn - nnP) > eps)) stop("nndist.ppx does not agree with pairdist") nn5 <- nndist(X, k=5) nn5P <- f(pairdist(X), 5) if(any(abs(nn5 - nn5P) > eps)) stop("nndist.ppx(k=5) does not agree with pairdist") nw <- nnwhich(X) nwP <- g(pairdist(X), 1) if(any(nw != nwP)) stop("nnwhich.ppx does not agree with pairdist") nw5 <- nnwhich(X, k=5) nw5P <- g(pairdist(X), 5) if(any(nw5 != nw5P)) stop("nnwhich.ppx(k=5) does not agree with pairdist") a <- nncross(X,Y) ncd <- nncross(X,Y, what="dist") ncw <- nncross(X,Y, what="which") if(any(ncw != gg(DXY, 1))) stop("incorrect result from nncross.ppx(what='which')") a2 <- nncross(X,Y, k=2) ncd <- nncross(X,Y, what="dist", k=2) ncw <- nncross(X,Y, what="which", k=2) if(any(ncw != gg(DXY, 2))) stop("incorrect result from nncross.ppx(k=2, what='which')") } if(FULLTEST) { ## special cases nndist(X[FALSE]) nndist(X[1]) nndist(X[1:3], k=4) nndist(X[1:3], k=1:4) nnwhich(X[FALSE]) nnwhich(X[1]) nnwhich(X[1:3], k=4) nnwhich(X[1:3], k=1:4) nncross(X[1:3], Y[FALSE]) nncross(X[1:3], Y[1]) nncross(X[1:3], Y[1:3], k=4) nncross(X[1:3], Y[1:3], k=1:4) } if(ALWAYS) { ## test of agreement between nngrid.h and knngrid.h ## dimyx=23 (found by trial-and-error) ensures that there are no ties a <- as.matrix(nnmap(cells, what="which", dimyx=23)) b <- as.matrix(nnmap(cells, what="which", dimyx=23, k=1:2)[[1]]) if(any(a != b)) stop("algorithms in nngrid.h and knngrid.h disagree") ## minnndist correctness X <- redwood3 eps <- sqrt(.Machine$double.eps) mfast <- minnndist(X) mslow <- min(nndist(X)) if(abs(mfast-mslow) > eps) stop("minnndist(X) disagrees with min(nndist(X))") ## maxnndist correctness mfast <- maxnndist(X) mslow <- max(nndist(X)) if(abs(mfast-mslow) > eps) stop("maxnndist(X) disagrees with max(nndist(X))") } if(ALWAYS) { ## minnndist, maxnndist code blocks Y <- superimpose(amacrine, amacrine[10:20]) a <- maxnndist(Y, positive=TRUE) u <- maxnndist(Y, positive=TRUE, by=marks(Y)) b <- minnndist(Y, positive=TRUE) v <- minnndist(Y, positive=TRUE, by=marks(Y)) ## nnmap code blocks A <- nnmap(cells[FALSE]) A <- nnmap(cells, sortby="var") A <- nnmap(cells, sortby="x") A <- nnmap(cells, sortby="y") B <- nnmap(cells[1:3], k=4) B <- nnmap(cells[1:3], k=2:4) D <- nnmap(cells, outputarray=TRUE) } if(ALWAYS) { #' tests for has.close() #' (the default method uses nndist or pairdist, and can be trusted!) a <- has.close(redwood, 0.05) b <- has.close.default(redwood, 0.05) if(any(a != b)) stop("Incorrect result for has.close(X, r)") a <- has.close(redwood, 0.05, periodic=TRUE) a <- has.close.default(redwood, 0.05, periodic=TRUE) if(any(a != b)) stop("Incorrect result for has.close(X, r, periodic=TRUE)") Y <- split(amacrine) a <- with(Y, has.close(on, 0.05, off)) b <- with(Y, has.close.default(on, 0.05, off)) if(any(a != b)) stop("Incorrect result for has.close(X, r, Y)") a <- with(Y, has.close(on, 0.05, off, periodic=TRUE)) b <- with(Y, has.close.default(on, 0.05, off, periodic=TRUE)) if(any(a != b)) stop("Incorrect result for has.close(X, r, Y, periodic=TRUE)") } if(ALWAYS) { b <- bdist.pixels(letterR, style="coords") d <- bdist.pixels(letterR, dimyx=64, method="interpreted") } if(FULLTEST) { ## nnfun.ppp h <- nnfun(cells) Z <- as.im(h) d <- domain(h) h <- nnfun(amacrine, value="mark") d <- domain(h) Z <- as.im(h) h <- nnfun(longleaf, value="mark") d <- domain(h) Z <- as.im(h) } }) spatstat.geom/tests/testsR.R0000644000176200001440000000143114611065354015620 0ustar liggesusers#' #' Header for all (concatenated) test files #' #' Require spatstat.geom #' Obtain environment variable controlling tests. #' #' $Revision: 1.5 $ $Date: 2020/04/30 05:31:37 $ require(spatstat.geom) FULLTEST <- (nchar(Sys.getenv("SPATSTAT_TEST", unset="")) > 0) ALWAYS <- TRUE cat(paste("--------- Executing", if(FULLTEST) "** ALL **" else "**RESTRICTED** subset of", "test code -----------\n")) #' tests/randbasic.R #' Tests of basic random generation code #' $Revision: 1.1 $ $Date: 2021/09/09 09:59:23 $ local({ if(FULLTEST) { #' cases not covered in examples A <- runifrect(6, nsim=2) A <- rsyst(nx=4, nsim=2) A <- rjitter(cells, nsim=2, retry=FALSE) A <- rjitter(cells, nndist(cells)/2) A <- rjitter(cells[FALSE]) } }) spatstat.geom/MD50000644000176200001440000010521414766261237013374 0ustar liggesuserse966e9d4d98e6a7028ec8c5bb3ace615 *DESCRIPTION 04bcf7466d43ed922a3dd095ef5e4bcb *NAMESPACE 858a5392b9b931308ee0fd1e11a1ba5e *NEWS 61e66e2561a8a0e89e9c9d0fa32ff495 *R/First.R 7b5da2ffbcca4f497eb3c33f786306e3 *R/Math.im.R 44f8a71ab76fed0cb52bcee94c0262f8 *R/Math.imlist.R 0dbaad8b1cb9847f3d5acded4d97b6fc *R/aaa.R b4dbe22c70d3266b20e3515c31c0256c *R/affine.R 45b083d5dd832d99255a2a0930c5b108 *R/applynbd.R fa02ee59c82e9a7be6b05650a0f742de *R/areadiff.R 5125cf97bfc4b9398bf51f4d0b13bf3f *R/as.im.R 45162d5f54fc8fd3f384ea496fa43a3f *R/boundingbox.R cc3f8bffb96b961a96ba8ad83c30886c *R/boundingcircle.R 491c27407dcc4adadc9c43743a15a59a *R/breakptgeom.R efc113b306d0b4916fbffc01caf2d706 *R/bufftess.R af810a4aec1706ad6f5b8ea1de775f0e *R/by.ppp.R d984dcc3e3cf51b1bda64ea15a7cf4b5 *R/centroid.R eca522aca0b04c9773424ba04cd39767 *R/circarcs.R 55b8ccb851f8a2cf879ff18a57963304 *R/classes.R 7746fc2b30a2439d2acab6eddac01424 *R/clickpoly.R 741d77e0d5b228697f7510dbcf6be9a2 *R/clickppp.R 469a9843861b6d204359ea59a75e17ad *R/clip.psp.R 597b53e6d6f8bf0c127c94bdcc91a4cf *R/close3Dpairs.R 6e1a989c1e38eb6f81ac069de5a0337e *R/closepairs.R 2b6116c99692b04c64d77377186effc0 *R/colourschemes.R 1ed18d7da1357c6e49de04cc212e0424 *R/colourtables.R 2981e10272e916cd70b742d9c5f4e468 *R/colourtools.R afcc68d10693c407da14cecf9a86daff *R/connected.R e3ff30e17b737e6b82a239440b9dbe82 *R/convexdist.R 01f3ef8f6e61c4d7686fe0fcc203b15f *R/convexify.R dd5451066df5ffab2ccb336f7d1e8f0d *R/covering.R dd44ac026abb8668e5e832c2ce4c9e32 *R/cut.ppp.R 8d9c5b273d9d9450b69adfccbdc2e428 *R/deldir.R 3ba4635fd03cab726544deee31fbc704 *R/deltametric.R e68f9edd40ef7792cf6c4f8d3870a07f *R/diagram.R 80c76f7820b0f468d4b9a4d81c0d9f46 *R/disc.R 5c17de60e3b9536db49b784bbfa9fc96 *R/discarea.R 932e89eef43d606759d6dc6766df9787 *R/dist2dpath.R 96496a4e9d002652adef2223ffd975e6 *R/distan3D.R ecead658bd75cf01fa87003f4a3f9555 *R/distancemetrics.R 2cc4fbd0a6771de70444f4c8addd9152 *R/distances.R 9fcd580554528a2b523c60d64f1efaf8 *R/distances.psp.R 4dd0b46396fbf6e149ac0d0d41d1f8e0 *R/distanxD.R afd034a33468aa4f840f9c2109e17632 *R/distbdry.R 0e483112a46f4d2715ea95664296984a *R/distfun.R ee5e0d06408e1e98275b0e5a576bb31f *R/distmap.R 9c33a28d219e0a17c118a98574e4b8d0 *R/dummy.R cd528109597be854639dd7fbe226377e *R/edges2triangles.R 1539189a0ae07f00bc8488fb54b8f071 *R/edit.R c568e14e0b06fcc8ab2243b1a9afd4be *R/eval.im.R 7e491d198a1cb8866a4c5cbe98477868 *R/exactPdt.R 82f0c2597ae60271c9db658b30f2b89b *R/exactdt.R 087615e45fee7233bf762fdd4c3bceb1 *R/factors.R a78edb263ce2be48c9e5e829c28b8770 *R/fardist.R 0d8c663012546b61deb9db628fc33e71 *R/fft.R 28b46b8980e7c66355c36de02e0fb3a0 *R/flaky.R a080df24b68c4f85948c7f24e33add67 *R/flipxy.R ca97c5fe546c7b2d1ea8b370ee2b1cf8 *R/fourierbasis.R ac20192057a72cbc14a397470511157e *R/funxy.R 44f00d3d5b732cfedd8b9f7288871bf4 *R/hasclose.R 1c1e42f8a0d5d8670f89694ac25116a6 *R/headtail.R 1e6f05124674b83e0d62227fa4588b2c *R/hexagons.R 18f997d5269397ef4832f97fa7a82f12 *R/hyperframe.R ad2d307372e54737d930a67abab516a3 *R/hypersub.R 246c0785891e715010e41c569f41216a *R/images.R 7f9b47edabadcb43779e573342359fe4 *R/indicator.R 0b4f076f31f4da5797d90b7a146538cd *R/infline.R a9439ad99cfce09f0b29dbeaa77c0a92 *R/intensity.R a2ee158ac416139dd1d9f16db92e14b3 *R/interp.im.R b0a2b87c4a2a7e481bb4361c006c4402 *R/is.R 991ca4cb22e1e5e52ee08948188745b7 *R/is.subset.owin.R ab6f587e62e9709ceb246fe71c292786 *R/layered.R 5affa028f6bbd36a38ebb1ecba7e7f5e *R/levelset.R 52a89f9b4655094430fc919796ae31c7 *R/listof.R 9163a961ba96bac39140a95581a29871 *R/logiquad.R cba3613617dc6e79eb954ed63c391977 *R/marks.R 3591cd315df9311e6a8c8847fe907a4f *R/metricPdt.R 7028ef95b1db442011f8a6c71362f296 *R/minkowski.R 817b25a9cfc6ee25d4bbd3a0951b5775 *R/minnndist.R ce8f38f8affb9f8882c739ac7b0f9a37 *R/morphology.R c9d8071400779a76bc4133d776b16dee *R/nearestsegment.R 82cdd0dae78e79ef34119b15cd2aad16 *R/nncross.R c82af709c19fd6e9a5941c646ada3836 *R/nncross3D.R 607ee8c66db31894fe0bd932d99d678e *R/nndist.R e065ee13fb35ad3e682377c80745e85d *R/nnfun.R 9bea29f3e95d5c09605c8d8c22de3b56 *R/nnmap.R ed5ceb9d18447ec47e0490a65e259b75 *R/nnmark.R 1844574ef86c3dadcb783a849dbff2cd *R/nnutils.R f06184b0e2b05912d2681ea9abff1933 *R/options.R 2f1126830dc8e8d2bcb142f421c9f164 *R/owin2mask.R 6c9bce8a5f1c0edfa1f9f3dea937d4c2 *R/periodify.R 9e3071633fa84fd679094a1ecdbd5210 *R/persp.im.R 4a9e019e5f85b9651b67978437ba172f *R/persp.ppp.R c73888548368e8f3a0b3c4a7abd1f51f *R/pickoption.R e0eeb6ebd736a1394fb5c9d9dee4f908 *R/pixellate.R 36140e921f54e2dbce194cc9642d012f *R/plot.anylist.R 77d7a4425c35d0c9d6afc6563a136f7a *R/plot.im.R f349c53f82c3bbff456f0068f54062c5 *R/plot.owin.R d00d91756ec226abc58d867e26e18e15 *R/plot.ppp.R 0ce87098152bc48636b1aa7911e61782 *R/plot.psp.R 7de8dfca9f086ef9e1d6d965f3bc55e4 *R/plot3d.R fb78ab475eba24c6202f9dafb81560a2 *R/pointsonlines.R 8cde54d74c814f8208364cf32e1fece4 *R/pointweights.R 93f8d51fa25fcd69340d2a72f74c6111 *R/polartess.R e59cdc092c14db2888891e7879a223fe *R/polygood.R f1c28a9e63f7fdad09729cdcf25a5c34 *R/pp3.R b4b8f0da9032e5ee7d1b5d64e8946b7b *R/ppp.R f93c36af4fe440a5994cc1d3797e34f0 *R/pppmatch.R 681b9c06acccbbb97bbd79b01b856715 *R/ppx.R def7805d8711dbf039d54fc996da739f *R/psp.R 0bf053f8e0f5932bd093deccd0d3b193 *R/psp2pix.R c784bd48092ca94b0fadfeee3cf92b21 *R/pspcross.R 2f4d79a05e995e8d6e2151a82e783ba2 *R/quadclass.R d096d1745d819e0f31df77092bc1b779 *R/quadratcount.R 6fc8f4e4e3df66212da5d59b39ce707a *R/quadscheme.R 40d92ee81858ea56b28c0b7892758491 *R/quantess.R 84efac90a60297aca6d1357cf1bf5474 *R/quasirandom.R 2691041550106236ae1af3f84afe3e30 *R/randombasic.R c25c56bc8e9d29f7a55fc41fed2312d1 *R/randomseg.R e71cc12bc401de8c1ce8833957f481d7 *R/rasterfilter.R 99f3f901362509f3494658b3b853981a *R/replace.ppp.R e34c842a124f8b2a99d7349dfa0800d3 *R/rescale.R 30fee31c09f49fe5452cf44fdaba1744 *R/rescue.rectangle.R 2259600b046e03fbd0dfa779960eea21 *R/ripras.R 47761a7635c5dee7d6414e200219b7f4 *R/rotate.R 649ff07655eb041cbd2c234b7e10cf9d *R/round.R 561a24d904aff0d09c1184106f6082ba *R/setcov.R 861789763712b249bd3c7d577783de3e *R/simplepanel.R db4db50a4d0eab7681d356a747a92188 *R/solist.R 9b459da2487961f0079ba08328b3f073 *R/split.ppp.R 00b6579253410b351a6ba536e42e655e *R/split.ppx.R 2f9a7d176f0627ac28b86e1f3f453ba8 *R/subset.R cc3e75c79d37c908d75d2542156329c2 *R/summary.im.R fd8885ecb274bfdae6fee1249fa65c2d *R/summary.quad.R 1cadd7278ca066ef831d2a47676f06e4 *R/superimpose.R 2608344c257a99866c7f025f73fe01ee *R/symbolmap.R 50b78af7927164f523baa8152a0b149a *R/terse.R c92f7668a21a3b8ca407fcd1bc92924c *R/tess.R b2f7eb1b1b1ee8cf40b3953c4620cc34 *R/tessfun.R a75061ccee5791f1e6533161159530b3 *R/texture.R c3032a7090caf3ec6606ec27f85a6772 *R/timed.R 7143eaf3c90beea6b15d60fc9fb65c77 *R/transmat.R 746a816204b6077878f2bb7e3bdb4fdb *R/triangulate.R 22c3a81e46a05c26b487dea66ba85f9b *R/unique.ppp.R 3ac4f6261aa8b5bded69fb2514aab026 *R/uniquemap.ppp.R cd8109217761fcfb6adcf72eeca2bfc5 *R/units.R 5a275a60736b9d87a342856c9da7a7f4 *R/unstack.R 6a1628c2cc4c675dc0d26729aeab2b3e *R/util.R 998db506a27ed60542581bf4cbfd0b66 *R/versions.R b1333ff8439dfd41629fdf56be763bea *R/weights.R c657d62d3f88d66bd77b735a2209bd33 *R/window.R 6541b37bf673aad264f2ce1569e8c4e8 *R/wingeom.R f2d49fc8f50fef7f76bcb3fc7f34efb4 *inst/CITATION ac6aa02ee30a52f0a13abc4a17ff0174 *inst/doc/downstream.txt 22383696995cd63f61a0ca5edccfb7d9 *inst/doc/packagesizes.txt 22383696995cd63f61a0ca5edccfb7d9 *inst/info/packagesizes.txt 12e68895fef0d3aa0bde45a0ddbadfa4 *inst/ratfor/Makefile 22e8a5189942ba190c13475b35459c7f *inst/ratfor/dppll.r 6d471ec061ea91398ba16323de56b9db *inst/ratfor/inxypOld.r 951ee2df828ad3de8c17340e0c5255b9 *man/Extract.anylist.Rd 97051c42b5e3d8cd1a45371453eddef3 *man/Extract.hyperframe.Rd 9d056066c7fb1b2436be97ea35feca3b *man/Extract.im.Rd 9df24cebfa86a43b332426d55b0d65cf *man/Extract.layered.Rd bfa41eea5bb69facbbecd9de7dc33106 *man/Extract.listof.Rd 740e2f7917d0e8e8df64e3f223ea09d6 *man/Extract.owin.Rd 04910cf80417208601213136a8e84a0a *man/Extract.ppp.Rd 0272f1bb66496689c11abf6d243e511e *man/Extract.ppx.Rd 8ff65133fc2b94fdba9cf10fed0a92b0 *man/Extract.psp.Rd 298518688a3bb5c06e7f4b332965f163 *man/Extract.quad.Rd 4555b288918db5e360c216aad5b314e9 *man/Extract.solist.Rd a8121ceae86f8ad44a18563a6b5f49c8 *man/Extract.splitppp.Rd c33eaac4943be0fd3b48733be446a052 *man/Extract.tess.Rd 051d69217e89ee7f12ef3b0fad2a779b *man/Frame.Rd 90cc8e9bc0d5737b8629f8515cd86751 *man/Math.im.Rd 99fe19493c5948747f84061f6c91b479 *man/Math.imlist.Rd fcd0b10c4c71c6d01500b70c894e578d *man/MinkowskiSum.Rd 27c6044f7c7280b25950223fd02bbc06 *man/Replace.im.Rd 49d34c3c61fc978f991d14be3d5c4bbc *man/Window.Rd 401b7002d5a266f401f17152920764bc *man/Window.tess.Rd da5e83b6e5a25aedb3393de676c087eb *man/add.texture.Rd 7f1844d4ab44df76f106c15aabc8beac *man/affine.Rd 84dfc8c15a9284165e04b90b09fcaa75 *man/affine.im.Rd fc995e9e9b66643bafff1e53f5ff02e9 *man/affine.owin.Rd ac33d8b824ff40e6bf8b53c6874a078b *man/affine.ppp.Rd e01b0ba8e973b9095c04aad3ad39c950 *man/affine.psp.Rd 20d823ee5726304d8805b2dee5aa987e *man/affine.tess.Rd a150795c3df1d7e1e33fe8590ea21966 *man/angles.psp.Rd 63c074e020a138be1c4661864b75e937 *man/anyNA.im.Rd 4d76934c668790fd8bedb5fa66ce31dc *man/anylist.Rd 9b7fa081f204c10df20d91f990a3cf31 *man/append.psp.Rd 3ec54c565aa425a8a902392b91b643b0 *man/applynbd.Rd 57adf249c91fde7afa6a3e4932f5ae54 *man/area.owin.Rd a464131b3976b97a8f2b124306328cc6 *man/areaGain.Rd e3aa25a48528c5309eb3d3dec93e5482 *man/areaLoss.Rd e68c56746424a0cf4b81db5722fae6ae *man/as.box3.Rd 037c6fddb0fde0d07a30da270c7d804c *man/as.boxx.Rd 05d855176c22a4a0a93ceb547b3ce967 *man/as.colourmap.Rd 0ec47d1f67cdada328f5a9d4b9b71916 *man/as.data.frame.hyperframe.Rd 2b0d501dcd65f686140f155e2079cdab *man/as.data.frame.im.Rd bfc1533729cb0b45727df7007ca0c0b4 *man/as.data.frame.owin.Rd 68add232e8114629c4e3bd3c95c5b367 *man/as.data.frame.ppp.Rd dec6385234ae397eaac223d97a806866 *man/as.data.frame.psp.Rd 619c05471b5ecce3f2f4b146ffe1ac3c *man/as.data.frame.tess.Rd bab4007f09e5570091a2801947a50940 *man/as.function.im.Rd c6228a5d9a3b4ec1a6934b027cc8d1f3 *man/as.function.owin.Rd dfb015ff88cacc15da0d99ec1c4331e4 *man/as.function.tess.Rd 9741be58acd0c68e0282000682a0260e *man/as.hyperframe.Rd d03abf7731ca84359964a1b0e20e77e6 *man/as.hyperframe.ppx.Rd 19ec587df0573946b99d0826e7469ca8 *man/as.im.Rd 6c32c91d76940f0a4a3b82b2e65bf751 *man/as.layered.Rd c0c11f3f6fb0b198733dcf5df1e7cb14 *man/as.mask.Rd f3083d1539e1ea6d8167d6be61fee79b *man/as.matrix.im.Rd 9d1146b67a744be20478cc498ab153d5 *man/as.matrix.owin.Rd 8ced460ff29ec41c042d9efa7ca5557d *man/as.owin.Rd 784877130e742b0dc026912f4b2344da *man/as.polygonal.Rd eed4794bb4d681b70e8d718c57eb088a *man/as.ppp.Rd dc38b90803e02ade5b102982721da676 *man/as.psp.Rd 5030c2b4d47d1418d5e2d334cc3adc4d *man/as.rectangle.Rd 26e06537bb661e6bd82f602c022a46aa *man/as.solist.Rd 0d9cd6cce23f80b956d287fefe9e6880 *man/as.tess.Rd 05fbcfec51977deceafb8f3e58a5e377 *man/bdist.pixels.Rd 20be1f3c558a4cabdcd457e78306b5f7 *man/bdist.points.Rd ea6d5883cc71d9f9840b2eb5b023585e *man/bdist.tiles.Rd a05272871a32f34d89c40e44f658162a *man/beachcolours.Rd 839f98fa5bc859af222b89acaa4636a5 *man/border.Rd e9947043b140536c1538f9e9e3f25ff0 *man/bounding.box.xy.Rd 2064969d0687cc616f53e4f3c5ae345c *man/boundingbox.Rd 9d81ef38928d9691d56347688131aed1 *man/boundingcircle.Rd 9e1705c6e356491a3af984967faa2780 *man/box3.Rd 54834701b5ec9fb27880597f2e7593e3 *man/boxx.Rd e9adc5209d43618e45b374ff7b7850de *man/bufftess.Rd 8535d23cee4edbc27dbc6fc6fc17042b *man/by.im.Rd c665237d07889815c3f33a9dbcccb5dc *man/by.ppp.Rd e04edebc13d5a65f3b448dea1dfa17d2 *man/cbind.hyperframe.Rd 4c79f397547acc10e33a556a83310f3a *man/centroid.owin.Rd 03654f79875e5a04c34f58ebe1940219 *man/chop.tess.Rd 7654a284e984253e10452f98b495237f *man/clickbox.Rd b6a864ee216e09891ef05f48211b4914 *man/clickdist.Rd 3295d098a0ee9741a140b28cad7307c9 *man/clickpoly.Rd 0db2141942eebc8b8461975ca3ed3dc1 *man/clickppp.Rd bde6cf2f59210136c60d71b1b2923138 *man/clip.infline.Rd 1d03f3fccb1458fead46bd33ce65ab90 *man/closepairs.Rd 35839fde193f882b1419c1b1e9fe498f *man/closepairs.pp3.Rd 9051c0c7f8ef7bbe655f7dd64b375077 *man/closetriples.Rd 5a8dc33a0fac88905e83874ba250eddb *man/closing.Rd 7de79a2551fe48e2846ecc7a3a1b233a *man/colourmap.Rd 69e63d1a9d3d4731bb05f0af15210bb9 *man/colouroutputs.Rd 6b48f30dc338828ecf3268b52ece04be *man/colourtools.Rd 6f4d7b3177e123b321d5c49895a90c80 *man/commonGrid.Rd 18bcea2d95af470c6d528b1b3c51c07b *man/compatible.Rd 0dbb6f2874f36a2409367b425a20970b *man/compatible.im.Rd 9d2c099b67451eeca3190f661f97c50e *man/complement.owin.Rd 9c37062f39c1f519e59ef50d6dabf3fe *man/concatxy.Rd e931d65c161a15996820ebd9a5311dd8 *man/connected.Rd 4f1ab6267d02ee22580a21d0d2f5f9f2 *man/connected.ppp.Rd a0d60d86c2c43e0412e6e1b13e003195 *man/connected.tess.Rd a074a34c03ebcdbba730fe7b51f05a80 *man/contour.im.Rd 396002ec53f04fe0e34230cbf813fb6a *man/contour.imlist.Rd 560d1fe32dc2d744ccb34e2702c18e46 *man/convexhull.Rd 7347cf485fe5c045d154cc97fd342308 *man/convexhull.xy.Rd b323e7ff70db6054fe6b1412bd88e92f *man/convexify.Rd f007feb643b71f52cbe99435a8f62052 *man/convexmetric.Rd f0de0252620168e31477d26ec8546e1d *man/convolve.im.Rd 8bfef4a4accabb9d55b51c356e436931 *man/coords.Rd 043d477a1eb8019a72195306231fa2be *man/corners.Rd e3e57cd9b8a120236f8c50d3185c6eab *man/covering.Rd 270668697df2da8368c716055fa16a39 *man/crossdist.Rd 1c030d5309d7039fca3acee9122322a7 *man/crossdist.default.Rd e1e28bedd9e4ffeeb096d8522620a5df *man/crossdist.pp3.Rd f648f026971de37016354ed5dcc48d6b *man/crossdist.ppp.Rd b69412588854da90e9af9cc0c38a49c9 *man/crossdist.ppx.Rd 809a911d3e1c8d9943f3d42d05a4ace3 *man/crossdist.psp.Rd 661c50d342e9e32e7cc02d041c7ac0be *man/crossing.psp.Rd af5b5fcc49b56411f212cb487cb1b0ce *man/cut.im.Rd 0402eb13286711831bb9acbdb39c7929 *man/cut.ppp.Rd 2af5e969b4ec5b7bb50f032954de7a77 *man/default.dummy.Rd 0e71f1be9b39a84e6f53f5d43730ae5b *man/default.image.colours.Rd 806fe692105d86c0ab3005bac340f877 *man/default.symbolmap.Rd ed3e099811be235c3e300592d6f0091b *man/default.symbolmap.ppp.Rd 1cdfeb2fa59c87920ec65dd2c2927a44 *man/delaunay.Rd 047c9546fc357109263295b55a5e4464 *man/delaunayDistance.Rd 610001c2e23c3a37d03748ce5dd477a0 *man/deltametric.Rd 2beb103dac6b9b07ed5ad10a3b05179f *man/diameter.Rd 83c7f4cb7455139a257c0af1bba8f730 *man/diameter.box3.Rd 4c28781cc6cdbb4a0122e422396920f3 *man/diameter.boxx.Rd c8748a865eabe0f776a867cc4a576d29 *man/diameter.owin.Rd e4a913df96f666d65445cebe5b01ca5e *man/dilated.areas.Rd 3d18ca12b7e01b627e61315bbe89b03c *man/dilation.Rd cd58d9b68a30f025525f3794dff174fa *man/dirichlet.Rd 1ad1403e16fd89dac665e9a8aa252076 *man/dirichletAreas.Rd c05c67725a37f500cbf05da730746636 *man/dirichletVertices.Rd 8eb78523fb904b02fbb62aaae85a4297 *man/dirichletWeights.Rd b34619466b312659e35efced730c8c89 *man/disc.Rd 4c4218514e71a0fcf58e752e8786fa69 *man/discpartarea.Rd 5f89a05ae2f87e01d71b709ebcf018b5 *man/discretise.Rd 34db2e9ea39424273e0420ca2bb93068 *man/discs.Rd dc4915b12efbc451c48be424854f147c *man/distfun.Rd af98debd7a3a66429a5c7b0b455fb712 *man/distmap.Rd 0ce4bda3332fc82b7624e3370b5aab7e *man/distmap.owin.Rd 885dd3b0a4c9a8ccd4f3085ba8d37cf7 *man/distmap.ppp.Rd a287975d788d2fb1e0a24b8f456825a3 *man/distmap.psp.Rd ca54a66c0706b40e8aad3ba4f0621b27 *man/domain.Rd f6b361ee19802275e239b31f06d60879 *man/duplicated.ppp.Rd 2c8a2832c36a28895f184e502e3b6624 *man/edges.Rd 34b1bf16cb0a8c40bffabcd2d64655ed *man/edges2triangles.Rd b1150d865b52154abe4431d659e9142f *man/edges2vees.Rd 1e473e02de85c9fcf7691e98ff40d1f1 *man/edit.hyperframe.Rd b7283957228c1bd0b45da50abde3bc0b *man/edit.ppp.Rd c4f40debb9f29a012581d45d958fad53 *man/ellipse.Rd b52845d95b7afb15f45e475802555714 *man/endpoints.psp.Rd 406ab1cde1b506f881777c6895445180 *man/eroded.areas.Rd d8c45e088d7805dc0e1597512dd19e0c *man/erosion.Rd efb075b7df9320223a187d100cc85c27 *man/erosionAny.Rd 37a80600401a568e3228c4537808bfef *man/eval.im.Rd 36da9624949f3a8e8f8eb63dcba6e81e *man/extrapolate.psp.Rd 2e069abc73ae90b4188071337c803ce1 *man/fardist.Rd 6f565504d8dc1d11fc70979b079dab80 *man/flipxy.Rd 2b692f946fbfd4b7d3bb7545d4b4a137 *man/fourierbasis.Rd 7eda29e0f8f2d4dec19ed1c1f854b866 *man/framedist.pixels.Rd eff3989548d3f6e1da0df51b97c76abd *man/funxy.Rd 952f8b71cb9e2a1bd0e4fc36e4ddbec2 *man/gridcentres.Rd 594037cbc9c88e44e187548324c34856 *man/gridweights.Rd 8682c3236a127ecaa7ae430c3f9e72e3 *man/grow.boxx.Rd 30375bff5e98a7539edce32aa22edb24 *man/grow.rectangle.Rd 67b93ee85e32946c411ff258b0191682 *man/harmonise.Rd 303ea75d0b886ef25c0618ab015c08d7 *man/harmonise.im.Rd 05eae00175dbeeaf8860df3f4b2559eb *man/harmonise.owin.Rd 7f167754f3ade4c054858b5dd5c3e728 *man/harmoniseLevels.Rd 53a50a8a89cc9655b91d6b10ba9394e4 *man/has.close.Rd 5bf86239f94433263d5c9f2f9bd5ed0b *man/headtail.Rd 2188c2ac9c0dcf15fdffa4da78239154 *man/hextess.Rd dc74236aa92bb751d34f7257ba45b76a *man/hist.funxy.Rd ce778c20311f92e7aac591d910034fbb *man/hist.im.Rd db10d3c27c2a50e3a2e069ff021a362f *man/hyperframe.Rd c84b428865f0b51a6070368ac4afeed6 *man/identify.ppp.Rd f9d14cd7306cd179193746eb85db3abe *man/identify.psp.Rd dcdf56d0f94e5f1848a701defb8615b6 *man/im.Rd fb6b5014bdb9aa43abb33197c8333966 *man/im.apply.Rd 9446424859568ad26c2d08378a2d9fa8 *man/im.object.Rd 5cf099bfda09c699261c0f8f04e2d2d0 *man/imcov.Rd 36fb37cec394cd3a85fe7e53fa7f83e4 *man/incircle.Rd fbb05bfe93cb434d601445c3caecdcd1 *man/infline.Rd 71852805127b4b97debe4dc1758eea9b *man/inside.boxx.Rd 94fd8bc363797a02244d547178fcb092 *man/inside.owin.Rd 306469f71751bf5ff13bb3870ddcb2d7 *man/integral.im.Rd f579a5bef82926c3d089e28ea457b081 *man/integral.tessfun.Rd 1008f8b942e0353e36c9f3ad816e4743 *man/intensity.Rd c9a5fb1ef03237c65ec5d29c1c9195b9 *man/intensity.ppp.Rd 5460b9db190b08032b212593e6575759 *man/intensity.ppx.Rd 1467ebde2a8fd707c3c1427670218282 *man/intensity.psp.Rd a92dc94c18c4450c6fc02d21d42052de *man/intensity.quadratcount.Rd d827a099a424de34819da1a1c399da83 *man/interp.colourmap.Rd 78d4a3147e74cf0e89180d043ede81d5 *man/interp.im.Rd c46ea39a4b123ca30915ceee2e754565 *man/intersect.boxx.Rd 81ff9ff948b7ed5d7e41867599e1c4cf *man/intersect.owin.Rd d831f60cde394ee51df17784167695c0 *man/intersect.tess.Rd a1b1b4ed17d3ce0bfe5f0c6c6c22456c *man/invoke.metric.Rd 64459f062e9f0a09f82adfda4f0789f1 *man/invoke.symbolmap.Rd d12463c2fffd2f9910da116502db9d89 *man/is.boxx.Rd 7283d672869ca83a845c6bbf7837f1ca *man/is.connected.Rd 4ca865e9e624a8130ee672fbd01dd78f *man/is.connected.ppp.Rd a3704f6c85f8c3d9fa4d111160467730 *man/is.convex.Rd 034fc8f4553fa6fb630179b1a8f4af1a *man/is.empty.Rd d6d24c19b232dd6551c046c8e5077e8b *man/is.im.Rd 75517dbb255d3421492fbcd41d2bfac2 *man/is.linim.Rd 877c3cc85bd27283141ccb039be462f1 *man/is.linnet.Rd 0ff90d89495c87169e03264a146ba4fa *man/is.lpp.Rd b9ed45dee034a89473de9b5ee8856449 *man/is.marked.Rd 6771d721b7a55dc3eee1333abaeea256 *man/is.marked.ppp.Rd 13f48457ddf35684f6ad5f9d5af8b0ee *man/is.multitype.Rd 0ff005454f03e60974816afd7f9a37a6 *man/is.multitype.ppp.Rd 0e40fc24543a9a2b342776b6ff5973ee *man/is.owin.Rd 7a7ac04c12206d04805e05c7c46e39c4 *man/is.ppp.Rd 006f6e69e5c82636c59f1c8f31b42e99 *man/is.rectangle.Rd d96fcc9cfc17f5d712737d75008bb7df *man/is.subset.owin.Rd e3ddd04a6557fd348a3345aef1f75d6b *man/layered.Rd 15b9725c1210edccb56275d9aa304aa4 *man/layerplotargs.Rd a8cda00ce5ed48007e36636c52f828f9 *man/layout.boxes.Rd 088137135052fd2e866d3a0372e5ba19 *man/lengths_psp.Rd 210fc7aaf9caf507e3a1fe5364b1cab4 *man/levelset.Rd 39f9d1446f83aa9f00e775ffc4df2b3c *man/lut.Rd 86394a54d161a4823e3defc3a7180c9d *man/macros/defns.Rd d2a9ee8b6a6e538dbf76f281f811f7da *man/marks.Rd cbe8805c7a3c8b2b452921800ab86f4e *man/marks.psp.Rd 2018946a1b50c71e54f53360e375311a *man/marks.tess.Rd c6a5fb4bd2c4e60924af3bbba4f61ba4 *man/markstat.Rd 3279693fd29b8e0e089d18ef5e7cb817 *man/matchingdist.Rd 17045f02e72e56107eccaf48a2807d96 *man/maxnndist.Rd 85c96d136f6c8e9dc5c9c8aa8870c98e *man/mean.im.Rd d7deffaef7f7438de2c1fb8b261838e7 *man/mergeLevels.Rd 652cccb76fedb05e50bca84ef9ffeae0 *man/methods.box3.Rd e63cc45947cf033f30ead672a8bba620 *man/methods.boxx.Rd 99a7dc9da5d2d6c05e2704af4420aadf *man/methods.distfun.Rd 9e8dfbdd28a7d4f99df870996cd2a8bb *man/methods.funxy.Rd 1ea46d68fdbb3cf71c03e2f482879f61 *man/methods.layered.Rd 71b5c324e5ede61a861cda98d7a555b7 *man/methods.pp3.Rd 5f3151c03841f8155df261ae2465ab01 *man/methods.ppx.Rd 7dd1d86d036b4c330d75aecf21e03ad0 *man/methods.unitname.Rd 10a718044992ac2022a841d71b92854e *man/metric.object.Rd 05abc784259447f91bb06ea1eadec032 *man/midpoints.psp.Rd fd7c2d5c8c968ca3d3e04a464f725b30 *man/multiplicity.ppp.Rd 03bb3d8dca973a6c13b3eeb8a7f06da9 *man/nearest.raster.point.Rd 987a5a3919b7341056d736998cfcf1fb *man/nearestValue.Rd aee872971b2811cfcf84f40531a7dc87 *man/nearestsegment.Rd 1f9ce73119ac2a79c48b019887a96ab5 *man/nestsplit.Rd 2237deaa70dc1358c2091d73ed591e74 *man/nncross.Rd 23da472c3741734f55fa656757d1eccf *man/nncross.pp3.Rd 6f0b6632a677a6222b6ae4d6a2556ec4 *man/nncross.ppx.Rd 7cbf6bed17278b32cf4e752582434e0a *man/nndist.Rd 2c7542ca42ff925b2c522856d260d611 *man/nndist.pp3.Rd 78a34e74cb2c27c928a41abb4eac0b39 *man/nndist.ppx.Rd eeb1431914ef4054c02588113ed13f7d *man/nndist.psp.Rd 6bc156723c8f3284f9b299e529b3d5ce *man/nnfun.Rd 35d5d356192c9cf0a6d4d4a48b75a076 *man/nnmap.Rd 6cb6e270b2be03bf33a49df5a3156f88 *man/nnmark.Rd d2e006a8588f1a1da91b886d3368358f *man/nnwhich.Rd b6166f88a493e6415940c335868a8e23 *man/nnwhich.pp3.Rd c42d68ad1588309b050beb4a53d5ec6b *man/nnwhich.ppx.Rd 7c7541b005684878bde93fc9a745440e *man/nobjects.Rd afbcfa29934991708540cd6a50d2ac8d *man/npoints.Rd 20d138bd69544c6250d3dadb29305c6f *man/nsegments.Rd 4e831d956a71811de072131538ffa9f0 *man/nvertices.Rd e54be9bb7feffb347eb2bb3b001316a4 *man/opening.Rd 0b059320eb292ee2c82683b6630bac7e *man/overlap.owin.Rd 69cb7c5e8ed15123c73a6e7d8125ee7b *man/owin.Rd f370af70324090e48ee26a2ed2820151 *man/owin.object.Rd 47bc3fd9def156bec3e41b871f589014 *man/owin2mask.Rd ecdf61a00688aed0cb7c653556bfce74 *man/pHcolourmap.Rd a334b67ef716e9124152624f15662c5f *man/padimage.Rd f22a02f7c2030b65c80a848f779ee213 *man/pairdist.Rd edaa3a3f7821c608b0288627185a9f2c *man/pairdist.default.Rd 3efc2130a370f1449ce2f370af51dc68 *man/pairdist.pp3.Rd 6f30b38b6c0051fbe69499f39fa46bb5 *man/pairdist.ppp.Rd a659fcc41e6c25559221347b202ad167 *man/pairdist.ppx.Rd 6a1f1dc9c8f623ba26e6688cff712a48 *man/pairdist.psp.Rd 60cfec08dc260c163c525c9edc4a6a66 *man/perimeter.Rd 239528d5c604129a1f8c7c8e3a3b3711 *man/periodify.Rd d9a5de0c0e34fa2de76517dfbcc5ae15 *man/persp.im.Rd bbe4e7f9aa0aa12417c13f97392703cb *man/persp.ppp.Rd 9698522dedc65f37cff92fe7d773e7b9 *man/perspPoints.Rd ad41f3d903371b41f2f402514c13b9d5 *man/pixelcentres.Rd dff9ce0e538441283ee74a3063e7c21b *man/pixellate.Rd e5bc33f18974019467edb47ca448902f *man/pixellate.owin.Rd f0ced930eaa8f51936f9e60ffea12d54 *man/pixellate.ppp.Rd d403b5f6c40373d219f27f0219fba93f *man/pixellate.psp.Rd 94338377428b307ffbb45caa58aca7ee *man/pixelquad.Rd 9347406567d8242ed91be45c87aca102 *man/plot.anylist.Rd edd6a8376cdda6e51c880c97781bcbf9 *man/plot.colourmap.Rd 69041708bd3062448a3b8cd686e47cc5 *man/plot.hyperframe.Rd 718857b11109e78220ff88cec7e236c6 *man/plot.im.Rd b74e2c145a035598ce2ee93a34bb5adb *man/plot.imlist.Rd 5ac6846440381b7039f61ffc9c8d0a44 *man/plot.layered.Rd 64dea75eb139f1c19c4176b018bbc12c *man/plot.listof.Rd 06c0e3c0c9fe8910ccca44466705c518 *man/plot.onearrow.Rd ec439182fe53e0c14478b9585d53a4ec *man/plot.owin.Rd 7cc3fed648e262b52b20262404b4aa8f *man/plot.pp3.Rd dddf65d0b46f31c1bfbb373d77d89ecd *man/plot.ppp.Rd 4c29a1e81309ce6dfa01d925efddf2b0 *man/plot.pppmatching.Rd ee6944b8913a7ecc6cc5471b37745072 *man/plot.psp.Rd a6c3d8063be2bfc459f2aa306d620c1c *man/plot.quad.Rd fea2d89deff7100d2e1b478b4be5d562 *man/plot.quadratcount.Rd 2b6ce143fe98deab47a21486f5f2543c *man/plot.solist.Rd 0c7dd9365f2a6e7efadfcc5e4e18a835 *man/plot.splitppp.Rd 0ff638b249d51cfea7c0c7ec3e784859 *man/plot.symbolmap.Rd 76589da08f3dd3db5c2618142b9206fb *man/plot.tess.Rd 803bba4ce84252fe7e91661b36ea472f *man/plot.textstring.Rd 10f37bfd9e89ca620ee4a153f19b61bb *man/plot.texturemap.Rd 00eb5d5a66b9ee3edd85814d350f0c94 *man/plot.yardstick.Rd 8eef4f9476af3bb9ce9644e314b181f0 *man/pointsOnLines.Rd dd629ce9d14a4eae6bf7d2c45ca44d97 *man/polartess.Rd 50515851b9951cf9a9ee2429345a66d0 *man/pp3.Rd 78d25ac47152fba822c5595de70689f2 *man/ppp.Rd 00462d867590860f3a1b588bbcf31311 *man/ppp.object.Rd 369f6dcbc57d9ee0589d2f4ffc441438 *man/pppdist.Rd e11cc8f0c7d49e07005e2b14e24dafa4 *man/pppmatching.Rd 27903647b3bb265c51719c8894494bfa *man/pppmatching.object.Rd 7ad75d21a56a85eb4a3af3105fd0fb91 *man/ppx.Rd deb86bb2408b5db2fb4b18db07d8f584 *man/print.im.Rd ca2c49a4a8bf792c78d714005a9424b8 *man/print.owin.Rd 02fac02da04266770ef3307bb303f658 *man/print.ppp.Rd 6e0624fc0182d41c6b557eb57c682a31 *man/print.psp.Rd ac00c3341a7f6dce5f69280a9cb36613 *man/print.quad.Rd 1e881d235b800d752e6c2b800b7e3ea2 *man/progressreport.Rd 56b0cd907c101d53abd16ea72665f290 *man/project2segment.Rd 5722aedb832a37a4dc33d6b627b263e6 *man/project2set.Rd 38345afd9e6fcc83d65ee94389c7ad0f *man/psp.Rd 50259be5c9f3766353dab049b10a4937 *man/psp.object.Rd 6a0270986130f372e52498219e75d0f1 *man/psp2mask.Rd c6fd6ba33e14070c08ee87107952a677 *man/quad.object.Rd d6aec03e52186bb25d3e6474b1a26a37 *man/quadratcount.Rd 32ec12831c4a458bcce681f5086febe3 *man/quadrats.Rd 9344cfbd425dbd3e4a3a6807c0a86cdc *man/quadscheme.Rd 45e5f4392417ddeb9ed6be18bd7ccd67 *man/quadscheme.logi.Rd e1cae728c7f365d099d486fc8e45cf2f *man/quantess.Rd dd719c0c8110bc2772f8d7912ecebcda *man/quantile.im.Rd e120a4d44afb812289c4ea36a3407a4e *man/quantilefun.im.Rd 68961b333902f94238d28d7dff64bfdf *man/quasirandom.Rd 7266a51131d3884bf96b03e561721671 *man/rQuasi.Rd 869cfeacb4f704c714ca4f042281c980 *man/raster.x.Rd f28c3268bd9b08e3070c881a4c787cf5 *man/rectdistmap.Rd a0c68ea64422a6edba5f9231338f0807 *man/reflect.Rd df95624d2972e9f5eb296c1ee9856092 *man/regularpolygon.Rd 20be7aeda8e4da71d02f871e2202115b *man/relevel.im.Rd d4c787d4577fec58f867c331ca0b2e93 *man/requireversion.Rd 4c8ad312df12e22f13174bf5622f38cc *man/rescale.Rd d94063817679b8520ffc28f1264a0f25 *man/rescale.im.Rd f2c4ebd5af97588cd5e7e3ced60de78c *man/rescale.owin.Rd ef1c25cdbd1a16a1c142ff4216c0dbb3 *man/rescale.ppp.Rd bd21a1e95cec89fd87e702c6916e7e90 *man/rescale.psp.Rd 12334801657f6ed3d3b0e6b3c80eee35 *man/rescue.rectangle.Rd e692265fcd2437cdd6e22effe2481f20 *man/restrict.colourmap.Rd 3393832640695615f6c99c1fc41f6ecc *man/rev.colourmap.Rd 2e591df588961978a36b7293c0fda359 *man/rexplode.Rd c5ce1488ee8e313ad78c398f546c8c1f *man/rgbim.Rd e2f8608735bfec6d306dea2be09ed6bd *man/ripras.Rd 9decd2a0be3587244a2eca64bbe15ab3 *man/rjitter.Rd 2a6d6f79b9bf7ba6ea08815d937a1470 *man/rlinegrid.Rd 46de1489970165e679298e0bfa806389 *man/rotate.Rd ac9a85fac4ba1a83841e50b65c67cc12 *man/rotate.im.Rd 1cca2bf91ce0897c70c83eebe2e0df46 *man/rotate.infline.Rd 6ccdedf240d57ce71c1bd7d03aa2e899 *man/rotate.owin.Rd e6de8cb9f1e09137d0d45baf45cd62eb *man/rotate.ppp.Rd 9f3fade667205c62415a1f97fd609bcb *man/rotate.psp.Rd d9898ffe70c600e04ae1d90150958090 *man/round.ppp.Rd fbf5bbd9241309b46378540a88e416a0 *man/rounding.ppp.Rd 38c8e9825a27d2e98e21c7618cfb9b72 *man/rsyst.Rd c5d3d8890255ea2ed99542aa58eb4e81 *man/run.simplepanel.Rd 833978befd73632b88147a06134f5bd8 *man/runifrect.Rd 9a64571432387abd7755ea566c816b5c *man/scalardilate.Rd a847cfd828fed5a9b2405240961865c5 *man/scaletointerval.Rd 06ae579a38031e3e417a73daafd3789e *man/scanpp.Rd 844656835d998b29a13720cf3dc80200 *man/selfcrossing.psp.Rd a9766e9a8eeb883777800f10cde7461b *man/selfcut.psp.Rd 289b684b595c6df72fdbf05abf8ecbf4 *man/sessionLibs.Rd a846f2abce7bbc7c7fbe7d5159ee7574 *man/setcov.Rd c9d619e191ae1c73f0df5fe95c1185ef *man/shift.Rd 45dd8f9f531004bd591d226f1d9e2dd7 *man/shift.im.Rd 0b91ceae8492d715fa8f54b1c4b20b4a *man/shift.owin.Rd f74722bb5467716eb489baa1f8241111 *man/shift.ppp.Rd cedcdcd549e1e8b4c30ac2faff4e05f6 *man/shift.ppx.Rd 1538f5ebe5dcce4327c659f72def0e16 *man/shift.psp.Rd ecbaeaebcafe20952c1a38fb8410e0ce *man/sidelengths.owin.Rd 59e8f58e03cd57c4b15f6d888b15d9c0 *man/simplepanel.Rd 99ebdd81548bc884bd7dc69feed637a2 *man/simplify.owin.Rd 2dea2a4633129caed8024c5a9b521eeb *man/solapply.Rd bd0c088722b2ab0ed1f888fff75139e4 *man/solist.Rd 8a06c516216701c55b29d991c9deb5a1 *man/solutionset.Rd 2f2b1a7f76f1ad52fd10304afc65186b *man/spatdim.Rd 95b6c4119e63b2b47e30758d05e8d081 *man/spatstat.geom-deprecated.Rd a647f97e01b9ffbee9123b2d17b2a88d *man/spatstat.geom-internal.Rd 9fb1f330715103b78cae0eea981dd656 *man/spatstat.geom-package.Rd c27b57ffa272542e5afc9b8865157162 *man/spatstat.options.Rd c542af7c96e45067fd97f43574d48da6 *man/split.hyperframe.Rd 292f195808fc9d04a39941d200831aaa *man/split.im.Rd 4f7f9e10c8958e2bd7e334493e89e31a *man/split.ppp.Rd 77393c24ac21a2cf61926efdc140d205 *man/split.ppx.Rd f8ca3f4632db9ba53e39edb98c39e95c *man/spokes.Rd 4a8813dd800e5b74f847a19947e1d682 *man/square.Rd 6ce780c1db71fbe485926a0a3230bc2e *man/stratrand.Rd 623138d90e1dc24eba152d8c2b5928c2 *man/subset.hyperframe.Rd 1826718e2d02aa8a0c3d3170d0578ce7 *man/subset.ppp.Rd db7828e15db8ca8ed814cc958ce66d67 *man/subset.psp.Rd 6f40b323e1ce8a8774f8a5368bed3167 *man/summary.anylist.Rd 90aca7b121556d8c3cde4387f50f0c86 *man/summary.distfun.Rd d0fe66866ca1d4901ad822a22de28094 *man/summary.im.Rd 48df7eebf9876aa61c2a0b5271fac5d9 *man/summary.listof.Rd 2a7c1544a5ceec886b000b45bfa56166 *man/summary.owin.Rd 1ca63a0cd3d799d6f1b167e97c18f076 *man/summary.ppp.Rd f3e0a6f7d1ecd0c771e02c3ecf8f2bf9 *man/summary.psp.Rd f23cc00208383929a5281303b5548643 *man/summary.quad.Rd 935671509f14b24888c6baa8152b53b7 *man/summary.solist.Rd c02c6c29aaef46d99d5ee877df7aaa48 *man/summary.splitppp.Rd f5b2c9d71c697ca0270d51df5a92f965 *man/superimpose.Rd add51a0991aa0ca71e78fc0600a9b2b3 *man/symbolmap.Rd b43e0453b434ba99b03ac433ce3f0a6f *man/tess.Rd 1a419c361a9579fd728c6482d42d0766 *man/test.crossing.psp.Rd 766154132888085e59081410bec2501b *man/text.ppp.Rd 44e4516ec3b5e2d588d381b7ac48697e *man/texturemap.Rd 08083e8bca2fa06e81d8718c2b66172c *man/textureplot.Rd 2f381662f92656dc153405817e035cc8 *man/tile.areas.Rd c053ac5ce09efc52424d337e1dcf12fc *man/tileindex.Rd e0a376a3362f09764ca9ae059a30fa85 *man/tilenames.Rd 1e0468de33d16a5faf3848ec1f6a6693 *man/tiles.Rd fd49521e7c21490bf42ec11b02aca531 *man/tiles.empty.Rd c2ae1e4fdce205ccfbcf484572868041 *man/timeTaken.Rd 9717810f60a2e475c1bcb4a3b3899293 *man/timed.Rd 33855ed0e811bb2984cdf15156ca0a21 *man/transmat.Rd fc56759d36af58ff75ffddb35ed1fca5 *man/triangulate.owin.Rd df2c4468d4c21b91dca2b6b89cf20bd9 *man/trim.rectangle.Rd bd757420f082ebea02b737655307ee08 *man/tweak.colourmap.Rd 1be973718cce78d819de34bf4d1aa92b *man/union.quad.Rd 372e71d05d84621b1d50af8470af914f *man/unique.ppp.Rd c12648c30d9061be06f2a9036759550a *man/uniquemap.ppp.Rd 20011709bbed545131da02a749d34c86 *man/unitname.Rd 0ce511b20ecc29ac119dad9afe5467b0 *man/unmark.Rd ba80bf313a02aa646cbb84838a9c1b78 *man/unstack.ppp.Rd 3cd68a28ae00729a7aa40c05beff2705 *man/unstack.solist.Rd 31980d6c449e7e73374eb8acd11dc7eb *man/update.symbolmap.Rd 95fa52445da1e49eaf51a6f73408b355 *man/venn.tess.Rd f7e40b90eb6625bda72e31d539b3ae80 *man/vertices.Rd 3e6b66ba2f5b820be0568df96b27f50a *man/volume.Rd a0732083f93b9a4dfd053a47be257b7d *man/where.max.Rd b1ff0e2b0c6a501f8ce25f7c31a6b7ae *man/whichhalfplane.Rd 3789df6565db5709f0f92eb959bfd4dc *man/with.hyperframe.Rd 4e0573cb24d5d923db6ae673896ac1d6 *man/yardstick.Rd 1df792903d55fa6b289dd1b1a9d7a6ef *man/zapsmall.im.Rd 560b09987185ab6f2618f73d4b7d98c5 *src/areadiff.c 15c96da5753675c30125760d4cd874a7 *src/auctionbf.c d329f4a16a2486d0fbc64b8a22ef6a1a *src/bdrymask.c 542e6e474340e0aac3ed97f6a92777b4 *src/chunkloop.h e6c2bb01eb4b123255d2579ab351ef76 *src/close3pair.c 2ebf50de6feb7cc18dd72446fa94d033 *src/closefuns.h 085bf822979fbdd8cb6565747c8fab5c *src/closepair.c 2cc6931f580d3f705fa0f096d8de47f5 *src/connectgraph.c 4f2f21110c44d80409db30228ac9f575 *src/connectpix.c ee7b2dff3f0921cb39e1009db294f3ae *src/connectpix.h becea4a1ea42b8a39021c01abdc6459d *src/constants.h dcf500827ff4c8b060819be2b274a7d7 *src/crossloop.h 9d438b3137f879ab21f85378bba410a6 *src/dinfty.c 313607b4b4c9e2e03a31e5d94122a63d *src/discarea.c 655006f986c9b44cf6ffeda8876d6b83 *src/discs.c 734c79510bd1ba5ebaaa3e4c28f059bf *src/dist2dpath.c b8e39cf74bcbc31350f0d8b28914ce74 *src/dist2dpath.h 5b2d787e9f7da441e412f1f79928e557 *src/distan3.c 7c566395b93011f717783842e12bf2db *src/distances.c 6e1f412681e6b28716f04c8c2d203c91 *src/distmapbin.c d01ea69ef69b56df372f6266011f38f9 *src/distmapbin.h 7028f09de82307e1e46de69c104b7423 *src/dwpure.c 7f2a10ed27158ad0012d3a0cb66093d3 *src/exactPdist.c 60c421413f7e42fb932251d8d66fa6d1 *src/exactdist.c f7a6e3b0fe734ce44c852647af539efa *src/fardist.c ae97c2bb0e1cc33983b7ce71ebd63dce *src/fardist.h f64c32ad80b0c295009994ffb7299670 *src/hasclose.c 7a441c85a06aeaad161a3ffcae15227d *src/hasclose.h 3ac5b77bd4e5913fdace252c6eeaf0fb *src/init.c d6f4b2cd273b8e96396c383307c0bd45 *src/knn3Ddist.h b33197077824150955ca1361b93ddf1b *src/knn3DdistX.h 1f8a15d24baa7b5e766ee43ca89e95bb *src/knnXdist.h 59e2dbc2033e150ce7ccb6f855b3e8b2 *src/knndist.h 1cd06edba93745a01ec38473c5642aab *src/knndistance.c a2395135c878f29a069c2299b111a1da *src/knngrid.c 27b1357498fd6602e99e2202d79c71f8 *src/knngrid.h 767ddd93b5f66825c1ed17333a89be1d *src/loccum.c 4e29092470baee76e155d2fae3c9d34b *src/loccums.h 25dcd1e2da6967e029da0a8b5119c782 *src/loccumx.h 1028220268560005d5a352baa44bda0d *src/maxnnd.h e693bc68030357b3a637d85a38de8bec *src/metricPdist.c 140cea71fd3402bf08124b472b2b8ced *src/metricPdist.h 539ea916b0de7d9ef17aaaf821747066 *src/minnnd.c 77174e1ba7a99b19d28fbdaac6ac5c82 *src/minnnd.h 964909479a5a50efdade9693484daaec *src/nearestpix.c 02037ffb33337b38ac7967ab54595763 *src/nn3Ddist.c 7ffcd838e30f462373c7b38392af329c *src/nn3Ddist.h 7e268be4995f86d44ce3a50dee12e00c *src/nn3DdistX.h 7779139fa358ca5c11cb92fd0098bc0e *src/nnMDdist.c 00137f8c4da0d40c89ef948840aa9e0e *src/nndist.h 77ed878b788e1afda42946245dba0c1c *src/nndistX.h 2bd611ddafdc3f881b31af57cabc5fc7 *src/nndistance.c bac2bb99413a12ee94fc8ee85a8c917a *src/nngrid.c 4f1cd97e928024e2e530090fde5b8dee *src/nngrid.h acdf88b1cfedbbb87d81bb727761decd *src/pairloop.h e739ec6dcba5cb6e51892ce370d21a70 *src/periodic.c 3ec0b4840aa006539224f9d5941f01ed *src/poly2im.c 77a117fafdbb5bbed0bb23551a6f1666 *src/proto.h 0aafe2526edd017dc5fd7de2e11ed15b *src/quasirandom.c 615b05e6d7796156017ceac8f9589df0 *src/raster.c 668e8318237175ac56af1fcfdb41be29 *src/raster.h 239c401c2b5ddef0206c71c3b374552e *src/rasterfilter.c 64ceb36a9d82f91028f6e97815bd7e98 *src/scan.c 6d53d53fd8683ceed568486aba4fa2cb *src/seg2pix.c 7c1336802118f4b0dfd6ddfcc64a387f *src/seg2pix.h 75c0284249f8bd8fe01cada8ab167382 *src/trigraf.c 863c8d7bf79250652cab60e7b1a962aa *src/uniquemap.c dfd88f3c1c10b18be62c9d47496c49e9 *src/uniquemap.h 247ad8564b98259227c47ae909d170f9 *src/veegraf.c 13eb150c73b6d609d1915a229bda3171 *src/xyseg.c 5c127a9d5ddeaee8cc8f34b32218a3a5 *src/yesno.h 5662cc3feeb8b25a9e413547d82f4074 *tests/badwindow.txt c1624129ac630ef4653e3119d70ffa5b *tests/selfcross.txt 021f97f21651e0d842cbd561c2d05ae0 *tests/testsAtoC.R c3ec5358551fe13cd284e054d4b31b54 *tests/testsD.R 0ea5c7e4c4ed266a63f8c3523a2cff00 *tests/testsEtoF.R ce21ab2d46ed2e925241475eb5c07002 *tests/testsGtoJ.R bd48e397baa926bd320898c771fc2ecf *tests/testsK.R 2656e51d2502ce38411ac2618bdde3d6 *tests/testsL.R 9e8f43244f6213772e79404838bf1f49 *tests/testsM.R 0b2469c496c8928fc534b3d9d9b2ebe2 *tests/testsNtoO.R 5b7cea4bd8327e1834a80809d78d5804 *tests/testsP1.R 06ad32db3dcc8a9b4400985422d6b60c *tests/testsP2.R 27ce9d531eeb307369876b79c001a0b3 *tests/testsQ.R 894e8b51b2a4c1bb2c6b661bd959ab31 *tests/testsR.R d1e56759c96cbeed756898bd64cee7be *tests/testsS.R 96956e19b99889c263329e598d8d1315 *tests/testsT.R 4134499e19a374e39448f8a849ae9926 *tests/testsUtoZ.R spatstat.geom/R/0000755000176200001440000000000014765164152013257 5ustar liggesusersspatstat.geom/R/interp.im.R0000644000176200001440000000444314611065352015304 0ustar liggesusers# # interp.im.R # # $Revision: 1.6 $ $Date: 2018/07/30 14:29:25 $ # interp.im <- local({ lukimyu <- function(ccc, rrr, mat, defaults) { dimm <- dim(mat) within <- (rrr >= 1 & rrr <= dimm[1L] & ccc >= 1 & ccc <= dimm[2L]) result <- defaults result[within] <- mat[cbind(rrr[within], ccc[within])] result } interp.im <- function(Z, x, y=NULL, bilinear=FALSE) { stopifnot(is.im(Z)) if(!is.null(levels(Z))) stop("Interpolation is undefined for factor-valued images") xy <- xy.coords(x, y) x <- xy$x y <- xy$y ok <- inside.owin(x,y, as.owin(Z)) V <- Z$v ## get default lookup values (for boundary cases) fallback <- Z[ppp(x[ok], y[ok], window=as.rectangle(Z), check=FALSE)] ## Transform to grid coordinates ## so that pixel centres are at integer points, ## bottom left of image is (0,0) xx <- (x[ok] - Z$xcol[1L])/Z$xstep yy <- (y[ok] - Z$yrow[1L])/Z$ystep ## find grid point to left and below ## (may transgress boundary) xlower <- floor(xx) ylower <- floor(yy) cc <- as.integer(xlower) + 1L rr <- as.integer(ylower) + 1L dx <- xx - xlower dy <- yy - ylower if(bilinear) { ## 'orthodox' values <- ((1-dx) * (1-dy) * lukimyu(cc,rr,V,fallback) + dx * (1-dy) * lukimyu(cc+1,rr,V,fallback) + (1-dx) * dy * lukimyu(cc,rr+1,V,fallback) + dx * dy * lukimyu(cc+1,rr+1,V,fallback) ) } else { ## original & default ## determine whether (x,y) is above or below antidiagonal in square below <- (dx + dy <= 1) ## if below,interpolate Z(x,y) = (1-x-y)Z(0,0) + xZ(1,0) + yZ(0,1) ## if above,interpolate Z(x,y) = (x+y-1)Z(1,1) + (1-x)Z(0,1) + (1-y)Z(1,0) values <- ifelse(below, ( (1-dx-dy)*lukimyu(cc,rr,V,fallback) + dx*lukimyu(cc+1,rr,V,fallback) + dy*lukimyu(cc,rr+1,V,fallback) ), ( (dx+dy-1)*lukimyu(cc+1,rr+1,V,fallback) + (1-dx)*lukimyu(cc,rr+1,V,fallback) + (1-dy)*lukimyu(cc+1,rr,V,fallback) )) } result <- numeric(length(x)) result[ok] <- values result[!ok] <- NA return(result) } interp.im }) spatstat.geom/R/clickppp.R0000644000176200001440000000476714611065351015214 0ustar liggesusers#' Dominic Schuhmacher's idea #' #' $Revision: 1.17 $ $Date: 2019/11/15 07:12:52 $ #' clickppp <- local({ clickppp <- function(n=NULL, win=square(1), types=NULL, ..., add=FALSE, main=NULL, hook=NULL) { win <- as.owin(win) instructions <- if(!is.null(n)) paste("click", n, "times in window") else paste("add points: click left mouse button in window\n", "exit: press ESC or another mouse button") if(is.null(main)) main <- instructions #### single type ######################### if(is.null(types)) { plot(win, add=add, main=main, invert=TRUE) if(!is.null(hook)) plot(hook, add=TRUE) splat("Ready to click..") if(!is.null(n)) xy <- spatstatLocator(n=n, ...) else xy <- spatstatLocator(...) #' check whether all points lie inside window if((nout <- sum(!inside.owin(xy$x, xy$y, win))) > 0) { warning(paste(nout, ngettext(nout, "point", "points"), "lying outside specified window; window was expanded")) win <- boundingbox(win, xy) } X <- ppp(xy$x, xy$y, window=win) return(X) } ##### multitype ####################### ftypes <- factor(types, levels=types) #' input points of type 1 X <- getem(ftypes[1L], instructions, n=n, win=win, add=add, ..., pch=1) X <- X %mark% ftypes[1L] #' input points of types 2, 3, ... in turn naughty <- FALSE for(i in 2:length(types)) { Xi <- getem(ftypes[i], instructions, n=n, win=win, add=add, ..., hook=X, pch=i) Xi <- Xi %mark% ftypes[i] if(!naughty && identical(Xi$window, win)) { #' normal case X <- superimpose(X, Xi, W=win) } else { #' User has clicked outside original window. naughty <- TRUE #' Use bounding box for simplicity bb <- boundingbox(Xi$window, X$window) X <- superimpose(X, Xi, W=bb) } } if(!add) { if(!naughty) plot(X, main="Final pattern") else { plot(X$window, main="Final pattern (in expanded window)", invert=TRUE) plot(win, add=TRUE, invert=TRUE) plot(X, add=TRUE) } } return(X) } getem <- function(i, instr, ...) { main <- paste("Points of type", sQuote(i), "\n", instr) do.call(clickppp, resolve.defaults(list(...), list(main=main))) } clickppp }) clickdist <- function() { a <- spatstatLocator(2) return(pairdist(a)[1L,2L]) } spatstat.geom/R/exactdt.R0000644000176200001440000000477414611065351015041 0ustar liggesusers# # exactdt.S # S function exactdt() for exact distance transform # # $Revision: 4.24 $ $Date: 2022/05/21 09:52:11 $ # exactdt <- local({ die <- function(why) { stop(paste("ppp object format corrupted:", why)) } exactdt <- function(X, ...) { verifyclass(X, "ppp") w <- X$window if(spatstat.options("exactdt.checks.data")) { ## check validity of ppp structure bb <- as.rectangle(w) xr <- bb$xrange yr <- bb$yrange rx <- range(X$x) ry <- range(X$y) if(rx[1L] < xr[1L] || rx[2L] > xr[2L]) die("x-coordinates out of bounds") if(ry[1L] < yr[1L] || ry[2L] > yr[2L]) die("y-coordinates out of bounds") if(length(X$x) != length(X$y)) die("x and y vectors have different length") if(length(X$x) != X$n) die("length of x,y vectors does not match n") } w <- as.mask(w, ...) ## dimensions of result nr <- w$dim[1L] nc <- w$dim[2L] xcol <- w$xcol yrow <- w$yrow ## Handle empty pattern if(npoints(X) == 0) { dist <- matrix(Inf, nr, nc) inde <- matrix(NA_integer_ , nr, nc) bdry <- framedist.pixels(w, style="matrix") return(list(d = dist, i = inde, b = bdry, w=w)) } ## margins in C array mr <- 2 mc <- 2 ## full dimensions of allocated storage Nnr <- nr + 2 * mr Nnc <- nc + 2 * mc N <- Nnr * Nnc ## output rows & columns (R indexing) rmin <- mr + 1 rmax <- Nnr - mr cmin <- mc + 1 cmax <- Nnc - mc ## go res <- .C(SG_exact_dt_R, as.double(X$x), as.double(X$y), as.integer(X$n), as.double(xcol[1L]), as.double(yrow[1L]), as.double(xcol[nc]), as.double(yrow[nr]), nr = as.integer(nr), nc = as.integer(nc), mr = as.integer(mr), mc = as.integer(mc), distances = as.double(double(N)), indices = as.integer(integer(N)), boundary = as.double(double(N)), PACKAGE="spatstat.geom") ## extract dist <- matrix(res$distances, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] inde <- matrix(res$indices, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] bdry <- matrix(res$boundary, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] ## convert index from C to R indexing inde <- inde + 1L return(list(d = dist, i = inde, b = bdry, w=w)) } exactdt }) spatstat.geom/R/hypersub.R0000644000176200001440000002471714611065352015246 0ustar liggesusers## ## hypersub.R ## ## ## subset operations for hyperframes ## ## $Revision: 1.29 $ $Date: 2023/02/03 00:45:34 $ ## "[.hyperframe" <- function(x, i, j, drop=FALSE, strip=drop, ...) { x <- unclass(x) if(!missing(i)) { if(length(dim(i)) > 1) stop("Matrix index i is not supported in '[.hyperframe'", call.=FALSE) y <- x y$df <- x$df[i, , drop=FALSE] y$ncases <- nrow(y$df) y$hypercolumns <- lapply(x$hypercolumns, "[", i=i) x <- y } if(!missing(j)) { if(length(dim(j)) > 1) stop("Matrix index j is not supported in '[.hyperframe'", call.=FALSE) y <- x patsy <- seq_len(y$nvars) names(patsy) <- y$vname jj <- patsy[j] names(jj) <- NULL y$nvars <- length(jj) y$vname <- vname <- x$vname[jj] y$vtype <- vtype <- x$vtype[jj] y$vclass <- x$vclass[jj] if(ncol(x$df) != 0) y$df <- x$df[ , vname[vtype == "dfcolumn"], drop=FALSE] y$hyperatoms <- x$hyperatoms[ vname[ vtype == "hyperatom" ]] y$hypercolumns <- x$hypercolumns[ vname [ vtype == "hypercolumn" ] ] x <- y } if(drop) { nrows <- x$ncases ncols <- x$nvars if(nrows == 1 && ncols == 1 && strip) { ## return a single object y <- switch(as.character(x$vtype), dfcolumn = x$df[, , drop=TRUE], hypercolumn = (x$hypercolumns[[1L]])[[1L]], hyperatom = x$hyperatoms[[1L]]) return(y) } else if(nrows == 1) { ## return the row as a vector or a list if(strip && all(x$vtype == "dfcolumn")) return(x$df[ , , drop=TRUE]) n <- x$nvars y <- vector(mode="list", length=n) names(y) <- nama <- x$vname for(k in seq_len(n)) { namk <- nama[k] y[[k]] <- switch(as.character(x$vtype[k]), dfcolumn = x$df[ , namk, drop=TRUE], hyperatom = x$hyperatoms[[namk]], hypercolumn = (x$hypercolumns[[namk]])[[1L]] ) } return(as.solist(y, demote=TRUE)) } else if(ncols == 1) { ## return a column as an 'anylist'/'solist' or a vector switch(as.character(x$vtype), dfcolumn = { return(x$df[, , drop=TRUE]) }, hypercolumn = { y <- as.solist(x$hypercolumns[[1L]], demote=TRUE) names(y) <- row.names(x$df) return(y) }, hyperatom = { ## replicate it to make a hypercolumn ha <- x$hyperatoms[1L] names(ha) <- NULL hc <- rep.int(ha, x$ncases) hc <- as.solist(hc, demote=TRUE) names(hc) <- row.names(x$df) return(hc) } ) } } class(x) <- c("hyperframe", class(x)) return(x) } "$.hyperframe" <- function(x,name) { m <- match(name, unclass(x)$vname) if(is.na(m)) return(NULL) return(x[, name, drop=TRUE, strip=FALSE]) } "$<-.hyperframe" <- function(x, name, value) { y <- as.list(x) if(is.hyperframe(value)) { if(ncol(value) == 1) { y[name] <- as.list(value) } else { y <- insertinlist(y, name, as.list(value)) } } else { dfcol <- is.atomic(value) && (is.vector(value) || is.factor(value)) if(!dfcol && !is.null(value)) value <- as.list(value) y[[name]] <- value } z <- do.call(hyperframe, append(y, list(row.names=row.names(x), stringsAsFactors=FALSE))) return(z) } "[<-.hyperframe" <- function (x, i, j, value) { sumry <- summary(x) colnam <- sumry$col.names dimx <- sumry$dim igiven <- !missing(i) jgiven <- !missing(j) if(igiven) { if(length(dim(i)) > 1) stop("Matrix index i is not supported in '[<-.hyperframe'", call.=FALSE) singlerow <- ((is.integer(i) && length(i) == 1 && i > 0) || (is.character(i) && length(i) == 1) || (is.logical(i) && sum(i) == 1)) } else { i <- seq_len(dimx[1L]) singlerow <- FALSE } if(jgiven) { if(length(dim(j)) > 1) stop("Matrix index j is not supported in '[<-.hyperframe'", call.=FALSE) singlecolumn <- ((is.integer(j) && length(j) == 1 && j > 0) || (is.character(j) && length(j) == 1) || (is.logical(j) && sum(j) == 1)) } else { j <- seq_len(dimx[2L]) singlecolumn <- FALSE } if(!igiven && jgiven) { # x[, j] <- value if(singlecolumn) { # expecting single hypercolumn if(is.logical(j)) j <- names(x)[j] y <- get("$<-.hyperframe")(x, j, value) } else { # expecting hyperframe xlist <- as.list(x) xlist[j] <- as.list(as.hyperframe(value)) # the above construction accepts all indices including extra entries y <- do.call(hyperframe, append(xlist, list(row.names=row.names(x)))) } } else { ## x[, ] <- value or x[i, ] <- value or x[i,j] <- value ## convert indices to positive integers rowseq <- seq_len(dimx[1L]) colseq <- seq_len(dimx[2L]) names(rowseq) <- row.names(x) names(colseq) <- colnam I <- rowseq[i] J <- colseq[j] ## convert to lists xlist <- as.list(x) if(singlerow && singlecolumn) { vlist <- list(anylist(value)) nrowV <- ncolV <- 1 } else { hv <- if(is.hyperframe(value)) value else as.hyperframe(as.solist(value, demote=TRUE)) vlist <- as.list(hv) nrowV <- dim(hv)[1L] ncolV <- dim(hv)[2L] } if(nrowV != length(I)) { if(nrowV == 1) { ## replicate vlist <- lapply(vlist, rep, times=nrowV) } else stop(paste("Replacement value has wrong number of rows:", nrowV, "should be", length(I)), call.=FALSE) } if(ncolV != length(J)) { if(ncolV == 1) { ## replicate vlist <- rep(vlist, times=ncolV) } else stop(paste("Replacement value has wrong number of columns:", ncolV, "should be", length(J)), call.=FALSE) } ## replace entries for(k in seq_along(J)) { jj <- J[k] xlist[[jj]][I] <- vlist[[k]] } ## put back together y <- do.call(hyperframe, append(xlist, list(row.names=row.names(x)))) } return(y) } "[[.hyperframe" <- function(x, ...) { rr <- as.data.frame(row(x)) cc <- as.data.frame(col(x)) dimnames(rr) <- dimnames(cc) <- dimnames(x) chosen.rows <- unique(as.integer(rr[[...]])) chosen.cols <- unique(as.integer(cc[[...]])) nr <- length(chosen.rows) nc <- length(chosen.cols) if(nc == 0 || nr == 0) { ## should never be reached stop("No data selected", call.=FALSE) } else if(nc > 1) { ## should never be reached stop("More than one item (or column) of data selected", call.=FALSE) } if(nr == 1) { ## single item result <- x[chosen.rows, chosen.cols, drop=TRUE, strip=TRUE] } else if(length(chosen.rows) == nrow(rr)) { ## column result <- x[,chosen.cols, drop=TRUE, strip=FALSE] } else { ## subset of a column stop("Cannot select part of a column in '[['", call.=FALSE) } return(result) } "[[<-.hyperframe" <- function(x, i, j, value) { ## detect 'blank' arguments like second argument in x[i, ] ngiven <- length(sys.call()) nmatched <- length(match.call()) nblank <- ngiven - nmatched itype <- if(missing(i)) "absent" else "given" jtype <- if(missing(j)) "absent" else "given" if(nblank == 1) { if(!missing(i)) jtype <- "blank" if(!missing(j)) itype <- "blank" } else if(nblank == 2) { itype <- jtype <- "blank" } ## detect idiom x[[ ]] or x[[ , ]] if(itype != "given" && jtype != "given" && prod(dim(x)) > 1) stop("More than one cell or column of cells selected", call.=FALSE) ## find selected rows and columns rr <- as.data.frame(row(x)) cc <- as.data.frame(col(x)) dimnames(rr) <- dimnames(cc) <- dimnames(x) switch(paste0(itype, jtype), givengiven = { chosen.rows <- rr[[i, j]] chosen.cols <- cc[[i, j]] }, givenabsent = { chosen.rows <- rr[[i]] chosen.cols <- cc[[i]] }, givenblank = { chosen.rows <- rr[[i, ]] chosen.cols <- cc[[i, ]] }, absentgiven = { ## cannot occur chosen.rows <- rr[[, j]] chosen.cols <- cc[[, j]] }, absentabsent = { chosen.rows <- rr[[ ]] chosen.cols <- cc[[ ]] }, absentblank = { ## cannot occur chosen.rows <- rr[[ , ]] chosen.cols <- cc[[ , ]] }, blankgiven = { chosen.rows <- rr[[, j]] chosen.cols <- cc[[, j]] }, blankabsent = { ## cannot occur chosen.rows <- rr[[]] chosen.cols <- cc[[]] }, blankblank = { chosen.rows <- rr[[ , ]] chosen.cols <- cc[[ , ]] }) chosen.rows <- unique(as.integer(chosen.rows)) chosen.cols <- unique(as.integer(chosen.cols)) nr <- length(chosen.rows) nc <- length(chosen.cols) if(nc == 0 || nr == 0) { ## should never be reached stop("No cells selected", call.=FALSE) } else if(nc > 1) { ## should never be reached stop("More than one cell or column of cells selected", call.=FALSE) } if(nr == 1) { ## single item xj <- x[[chosen.cols]] if(!is.atomic(xj)) { ## check class of replacement value vcj <- unclass(x)$vclass[[chosen.cols]] if(!inherits(value, vcj)) stop(paste("Replacement value does not have required class", sQuote(vcj)), call.=FALSE) } xj[[chosen.rows]] <- value x[,chosen.cols] <- xj } else if(length(chosen.rows) == nrow(rr)) { ## column x[,chosen.cols] <- value } else { ## subset of a column stop("Cannot assign part of a column in '[[<-'", call.=FALSE) } return(x) } split.hyperframe <- local({ split.hyperframe <- function(x, f, drop=FALSE, ...) { y <- data.frame(id=seq_len(nrow(x))) z <- split(y, f, drop=drop) z <- lapply(z, getElement, name="id") out <- lapply(z, indexi, x=x) return(out) } indexi <- function(i, x) x[i,] split.hyperframe }) "split<-.hyperframe" <- function(x, f, drop=FALSE, ..., value) { ix <- split(seq_len(nrow(x)), f, drop = drop, ...) n <- length(value) j <- 0 for (i in ix) { j <- j%%n + 1L x[i, ] <- value[[j]] } x } spatstat.geom/R/ripras.R0000644000176200001440000000270314611065352014674 0ustar liggesusers# # ripras.S Ripley-Rasson estimator of domain # # # $Revision: 1.15 $ $Date: 2024/02/04 08:04:51 $ # # # # #------------------------------------- bounding.box.xy <- function(x, y=NULL) { xy <- xy.coords(x,y) if(length(xy$x) == 0) return(NULL) owinInternalRect(range(xy$x), range(xy$y), check=FALSE) } convexhull.xy <- function(x, y=NULL) { xy <- xy.coords(x, y) x <- xy$x y <- xy$y if(length(x) < 3) return(NULL) h <- rev(chull(x, y)) # must be anticlockwise if(length(h) < 3) return(NULL) w <- owin(poly=list(x=x[h], y=y[h]), check=FALSE) return(w) } ripras <- function(x, y=NULL, shape="convex", f) { xy <- xy.coords(x, y) n <- length(xy$x) w <- switch(shape, convex = convexhull.xy(xy), rectangle = boundingbox(xy), stop(paste("Unrecognised option: shape=", dQuote(shape)))) if(is.null(w)) return(NULL) # expansion factor if(!missing(f)) stopifnot(is.numeric(f) && length(f) == 1 && f >= 1) else switch(shape, convex = { # number of vertices m <- summary(w)$nvertices f <- if(m < n) 1/sqrt(1 - m/n) else 2 }, rectangle = { f <- (n+1)/(n-1) }) # centroid ce <- unlist(centroid.owin(w)) # shift centroid to origin W <- shift(w, -ce) # rescale W <- affine(W, mat=diag(c(f,f))) # shift origin to centroid W <- shift(W, ce) return(W) } spatstat.geom/R/versions.R0000644000176200001440000000535614611065353015254 0ustar liggesusers## ## versions.R ## ## version numbers ## ## The string P A C K A G E N A M E is substituted by filepp ## ## $Revision: 1.20 $ $Date: 2020/11/30 10:20:24 $ ## ##################### ## see also: ## versionstring.interact() interact.R ## versionstring.ppm() ppmclass.R # Get version number of current spatstat installation # This is now saved in the spatstat cache environment # rather than read from file every time versionstring.spatstat <- function() { if(!existsSpatstatVariable("SpatstatVersion")) store.versionstring.spatstat() getSpatstatVariable("SpatstatVersion") } store.versionstring.spatstat <- function() { vs <- read.dcf(file=system.file("DESCRIPTION", package="spatstat.geom"), fields="Version") vs <- as.character(vs) putSpatstatVariable("SpatstatVersion", vs) } # Extract major and minor versions only. majorminorversion <- function(v) { vp <- package_version(v) return(package_version(paste(vp$major, vp$minor, sep="."))) } versioncurrency.spatstat <- function(today=Sys.Date(), checkR=TRUE) { ## check version currency using dates msg <- NULL if(checkR) { ## check version of R if(!exists("getRversion") || getRversion() < "3.3") { msg <- "This version of R is very outdated; an upgrade is recommended" } else { rv <- R.Version() rdate <- try( as.Date(with(rv, ISOdate(year, month, day))), silent=TRUE) if(!inherits(rdate, "Date") || length(rdate) == 0 || (today - rdate > 365)) { ## R version is old; just warn about this msg <- paste(rv$version.string %orifnull% "R version", "is more than a year old;", "we strongly recommend upgrading to the latest version") } } } if(is.null(msg)) { ## check version of spatstat descfile <- system.file("DESCRIPTION", package="spatstat.geom") packdate <- as.Date(read.dcf(file=descfile, fields="Date")) elapsed <- today - packdate if(elapsed > 75) { if(elapsed > 365) { n <- floor(elapsed/365) unit <- "year" sowhat <- "we strongly recommend upgrading to the latest version." } else if(elapsed > 100) { n <- floor(elapsed/30) unit <- "month" sowhat <- "we recommend upgrading to the latest version." } else { n <- floor(elapsed/7) unit <- "week" sowhat <- "a newer version should be available." } expired <- if(n == 1) paste("a", unit) else paste(n, paste0(unit, "s")) ver <- versionstring.spatstat() msg <- paste("spatstat.geom", "version", ver, "is out of date by more than", paste0(expired, ";"), sowhat) } } return(msg) } spatstat.geom/R/units.R0000644000176200001440000001364614611065353014547 0ustar liggesusers# # Functions for extracting and setting the name of the unit of length # # $Revision: 1.32 $ $Date: 2020/12/06 02:32:01 $ # # unitname <- function(x) { UseMethod("unitname") } unitname.owin <- function(x) { u <- as.unitname(x$units) return(u) } unitname.ppp <- function(x) { u <- as.unitname(x$window$units) return(u) } unitname.im <- function(x) { u <- as.unitname(x$units) return(u) } unitname.default <- function(x) { return(as.unitname(attr(x, "units"))) } "unitname<-" <- function(x, value) { UseMethod("unitname<-") } "unitname<-.owin" <- function(x, value) { x$units <- as.unitname(value) return(x) } "unitname<-.ppp" <- function(x, value) { w <- x$window unitname(w) <- value x$window <- w return(x) } "unitname<-.im" <- function(x, value) { x$units <- as.unitname(value) return(x) } "unitname<-.default" <- function(x, value) { if(is.null(x)) return(x) attr(x, "units") <- as.unitname(value) return(x) } ### class 'unitname' makeunitname <- function(sing="unit", plur="units", mul = 1) { if(!is.character(sing)) stop("In unit name, first entry should be a character string") if(!is.character(plur)) stop("In unit name, second entry should be a character string") mul <- try(as.numeric(mul), silent=TRUE) if(inherits(mul, "try-error")) stop("In unit name, third entry should be a number") if(length(mul) != 1 || mul <= 0) stop("In unit name, third entry should be a single positive number") u <- list(singular=sing, plural=plur, multiplier=mul) if(mul != 1 && (sing=="unit" || plur=="units")) stop(paste("A multiplier is not allowed", "if the unit does not have a specific name")) class(u) <- "unitname" return(u) } as.unitname <- function(s) { if(inherits(s, "unitname")) return(s) if(inherits(s, "units")) s <- unclass(s) ## another package s <- as.list(s) n <- length(s) if(n > 3) stop(paste("Unit name should be a character string,", "or a vector/list of 2 character strings,", "or a list(character, character, numeric)")) out <- switch(n+1, makeunitname(), makeunitname(s[[1]], s[[1]]), makeunitname(s[[1]], s[[2]]), makeunitname(s[[1]], s[[2]], s[[3]])) return(out) } print.unitname <- function(x, ...) { mul <- x$multiplier if(mul == 1) cat(paste(x$singular, "/", x$plural, "\n")) else cat(paste(mul, x$plural, "\n")) return(invisible(NULL)) } as.character.unitname <- function(x, ...) { mul <- x$multiplier return(if(mul == 1) x$plural else paste(mul, x$plural)) } is.vanilla <- function(u) { u <- as.unitname(u) z <- (u$singular == "unit") && (u$multiplier == 1) return(z) } summary.unitname <- function(object, ...) { x <- object scaled <- (x$multiplier != 1) named <- (x$singular != "unit") vanilla <- !named && !scaled out <- if(vanilla) { list(legend = NULL, axis = NULL, explain = NULL, singular = "unit", plural = "units") } else if(named & !scaled) { list(legend = paste("Unit of length: 1", x$singular), axis = paren(x$plural, type=spatstat.options('units.paren')), explain = NULL, singular = x$singular, plural = x$plural) } else { expanded <- paste(x$multiplier, x$plural) expla <- paren(paste("one unit =", expanded), type=spatstat.options('units.paren')) list(legend = paste("Unit of length:", expanded), axis = expla, explain = expla, singular = "unit", plural = "units") } out <- append(out, list(scaled = scaled, named = named, vanilla = vanilla)) class(out) <- "summary.unitname" return(out) } print.summary.unitname <- function(x, ...) { if(x$vanilla) cat("Unit of length (unnamed)\n") else cat(paste(x$legend, "\n")) invisible(NULL) } compatible <- function(A, B, ...) { UseMethod("compatible") } compatible.unitname <- function(A, B, ..., coerce=TRUE) { A <- as.unitname(A) if(missing(B)) return(TRUE) B <- as.unitname(B) # check for null units Anull <- summary(A)$vanilla Bnull <- summary(B)$vanilla # `coerce' determines whether `vanilla' units are compatible with other units coerce <- as.logical(coerce) # agree <- if(!Anull && !Bnull) isTRUE(all.equal(A,B)) else if(Anull && Bnull) TRUE else coerce # if(!agree) return(FALSE) # A and B agree if(length(list(...)) == 0) return(TRUE) # recursion return(compatible.unitname(B, ...)) } harmonize.unitname <- harmonise.unitname <- function(..., coerce=TRUE, single=FALSE) { argh <- list(...) n <- length(argh) if(n == 0) return(NULL) u <- lapply(argh, as.unitname) if(n == 1) return(if(single) u[[1L]] else u) if(coerce) { #' vanilla units are compatible with another unit s <- lapply(u, summary) v <- sapply(s, getElement, name="vanilla") if(all(v)) return(if(single) u[[1L]] else u) u <- u[!v] } z <- unique(u) if(length(z) > 1) stop("Unitnames are incompatible", call.=FALSE) if(single) return(z[[1]]) z <- rep(z, n) names(z) <- names(argh) return(z) } # class 'numberwithunit': numeric value(s) with unit of length numberwithunit <- function(x, u) { u <- as.unitname(u) x <- as.numeric(x) unitname(x) <- u class(x) <- c(class(x), "numberwithunit") return(x) } "%unit%" <- function(x, u) { numberwithunit(x, u) } format.numberwithunit <- function(x, ..., collapse=" x ", modifier=NULL) { u <- summary(unitname(x)) uname <- if(all(x == 1)) u$singular else u$plural y <- format(as.numeric(x), ...) z <- pasteN(paste(y, collapse=collapse), modifier, uname, u$explain) return(z) } as.character.numberwithunit <- function(x, ...) { return(format(x)) } print.numberwithunit <- function(x, ...) { cat(format(x, ...), fill=TRUE) return(invisible(NULL)) } spatstat.geom/R/unstack.R0000644000176200001440000000256314737152305015054 0ustar liggesusers#' #' unstack.R #' #' Methods for generic 'unstack' #' #' $Revision: 1.7 $ $Date: 2025/01/07 07:12:17 $ unstack.ppp <- unstack.psp <- unstack.tess <- function(x, ...) { trap.extra.arguments(...) marx <- marks(x, drop=FALSE) d <- dim(marx) if(is.null(d)) return(solist(x)) y <- rep(list(unmark(x)), d[2]) for(j in seq_along(y)) marks(y[[j]]) <- marx[,j,drop=FALSE] names(y) <- colnames(marx) return(as.solist(y)) } unstackFilter <- function(x) { ## deal with a whole swag of classes that do not need to be unstacked nonvectorclasses <- c("im", "owin", "quad", "quadratcount", "quadrattest", "funxy", "distfun", "nnfun", "linnet", "linfun", "influence.ppm", "leverage.ppm") y <- if(inherits(x, nonvectorclasses)) solist(x) else unstack(x) return(y) } unstack.solist <- function(x, ...) { trap.extra.arguments(...) y <- lapply(x, unstackFilter) z <- as.solist(unlist(y, recursive=FALSE)) return(z) } unstack.layered <- function(x, ...) { trap.extra.arguments(...) y <- lapply(x, unstackFilter) ny <- lengths(y) nx <- length(ny) if(all(ny == 1) || nx == 0) return(solist(x)) pax <- layerplotargs(x) pay <- rep(pax, times=ny) z <- unlist(y, recursive=FALSE) z <- layered(LayerList=z, plotargs=pay) return(z) } spatstat.geom/R/minkowski.R0000644000176200001440000000457014611065352015413 0ustar liggesusers#' #' minkowski.R #' #' Minkowski Sum and related operations #' #' $Revision: 1.8 $ $Date: 2020/06/11 01:03:54 $ "%(+)%" <- MinkowskiSum <- local({ MinkowskiSum <- function(A, B) { if(is.ppp(A)) return(UnionOfShifts(B, A)) if(is.ppp(B)) return(UnionOfShifts(A, B)) ## extract lists of simply-connected polygons AA <- simplepolygons(A) BB <- simplepolygons(B) ## determine common resolution for polyclip operations eps <- mean(c(sidelengths(Frame(A)), sidelengths(Frame(B))))/2^30 p <- list(eps=eps) ## compute Minkowski sums of simply-connected pieces result <- NULL for(a in AA) { partial.a <- NULL for(b in BB) { contrib.ab <- polyclip::polyminkowski(a, b, x0=0, y0=0, eps=eps) partial.a <- union.owin(partial.a, poly2owin(contrib.ab), p=p) } result <- union.owin(result, partial.a, p=p) } ## resolve unitname un <- list(unitname(A), unitname(B)) un <- unique(un[!sapply(un, is.vanilla)]) if(length(un) == 1) unitname(result) <- un[[1L]] return(result) } poly2owin <- function(z) owin(poly=z, check=FALSE) simplepolygons <- function(A) { if(is.psp(A)) return(psp2poly(A)) ## convert to owin, then polygonal A <- as.polygonal(A) ## separate into simply-connected pieces AA <- break.holes(A)$bdry return(AA) } ## handle segment patterns as well psp2poly <- function(X) apply(as.matrix(X$ends), 1, seg2poly) seg2poly <- function(z) with(as.list(z), list(x=c(x0, x1, x0), y=c(y0,y1,y0))) ## UnionOfShifts <- function(X, V) { #' compute the union or superposition of copies of X by vectors in V v <- as.matrix(coords(V)) n <- nrow(v) Y <- vector(mode="list", length=n) for(i in seq_len(n)) Y[[i]] <- shift(X, v[i,]) Y <- as.solist(Y) if(is.owin(X)) { Z <- union.owin(Y) } else { #' X is a pattern of objects in a window W <- MinkowskiSum(Window(X), Window(V)) Z <- superimpose(Y, W=W) } return(Z) } MinkowskiSum }) dilationAny <- function(A, B) { MinkowskiSum(A, reflect(B)) } "%(-)%" <- erosionAny <- function(A, B) { D <- Frame(A) Dplus <- grow.rectangle(D, 0.1 * shortside(D)) Ac <- complement.owin(A, Dplus) AcB <- MinkowskiSum(Ac, reflect(B)) if(is.subset.owin(D, AcB)) return(emptywindow(D)) C <- complement.owin(AcB[Dplus], Dplus)[D] return(C) } spatstat.geom/R/nnmark.R0000644000176200001440000000234414611065352014663 0ustar liggesusers# # nnmark.R # # $Revision: 1.7 $ $Date: 2018/02/14 08:00:59 $ nnmark <- local({ nnmark <- function(X, ..., k=1, at=c("pixels", "points")) { stopifnot(is.ppp(X)) stopifnot(is.marked(X)) at <- match.arg(at) mX <- marks(X) switch(at, pixels = { Y <- nnmap(X, k=k, what="which", ...) switch(markformat(X), vector={ result <- eval.im(mX[Y]) }, dataframe = { mX <- as.list(as.data.frame(mX)) result <- solapply(mX, lookedup, indeximage=Y) }, stop("Marks must be a vector or dataframe")) }, points = { Y <- nnwhich(X, k=k) switch(markformat(X), vector={ result <- mX[Y] }, dataframe = { result <- mX[Y,, drop=FALSE] row.names(result) <- NULL }, stop("Marks must be a vector or dataframe")) }) return(result) } lookedup <- function(xvals, indeximage) eval.im(xvals[indeximage]) nnmark }) spatstat.geom/R/quasirandom.R0000644000176200001440000000266714611065352015730 0ustar liggesusers## ## quasirandom.R ## ## Quasi-random sequence generators ## ## $Revision: 1.8 $ $Date: 2022/05/21 09:52:11 $ ## vdCorput <- function(n, base) { stopifnot(is.prime(base)) z <- .C(SG_Corput, base=as.integer(base), n=as.integer(n), result=as.double(numeric(n)), PACKAGE="spatstat.geom") return(z$result) } Halton <- function(n, bases=c(2,3), raw=FALSE, simplify=TRUE) { d <- length(bases) if(d==2 && !raw && simplify) return(ppp(vdCorput(n, bases[1]), vdCorput(n, bases[2]), window=owin(), check=FALSE)) z <- matrix(, nrow=n, ncol=d) for(j in 1:d) z[,j] <- vdCorput(n, bases[j]) if(raw || d < 2) return(z) b <- do.call(boxx, rep(list(c(0,1)), d)) return(ppx(z, b, simplify=simplify)) } Hammersley <- function(n, bases=2, raw=FALSE, simplify=TRUE) { d <- length(bases) + 1 z <- cbind(Halton(n, bases, raw=TRUE), (1:n)/n) dimnames(z) <- NULL if(raw || d < 2) return(z) b <- do.call(boxx, rep(list(c(0,1)), d)) return(ppx(z, b, simplify=simplify)) } rQuasi <- function(n, W, type=c("Halton", "Hammersley"), ...) { R <- as.rectangle(W) type <- match.arg(type) X <- switch(type, Halton=Halton(n, ...), Hammersley=Hammersley(n, ...)) Y <- ppp(R$xrange[1] + diff(R$xrange) * X$x, R$yrange[1] + diff(R$yrange) * X$y, window=R, check=FALSE) if(!is.rectangle(W)) Y <- Y[W] return(Y) } spatstat.geom/R/by.ppp.R0000644000176200001440000000062414611065351014603 0ustar liggesusers# # by.ppp.R # # $Revision: 1.6 $ $Date: 2015/10/21 09:06:57 $ # by.ppp <- function(data, INDICES=marks(data), FUN, ...) { if(missing(INDICES)) INDICES <- marks(data, dfok=FALSE) if(missing(FUN)) stop("FUN is missing") y <- split(data, INDICES) z <- list() for(i in seq_along(y)) z[[i]] <- FUN(y[[i]], ...) names(z) <- names(y) z <- as.solist(z, demote=TRUE) return(z) } spatstat.geom/R/summary.quad.R0000644000176200001440000001142314611065352016021 0ustar liggesusers# # summary.quad.R # # summary() method for class "quad" # # $Revision: 1.12 $ $Date: 2018/07/06 02:05:31 $ # summary.quad <- local({ sumriz <- function(ww) { if(length(ww) > 0) return(list(range=range(ww), sum=sum(ww))) else return(NULL) } summary.quad <- function(object, ..., checkdup=FALSE) { verifyclass(object, "quad") X <- object$data D <- object$dummy s <- list( logi = inherits(object, "logiquad"), data = summary.ppp(X, checkdup=checkdup), dummy = summary.ppp(D, checkdup=checkdup), param = object$param) ## make description of dummy point arrangement dpar <- object$param$dummy eps.given <- dpar$orig$eps # could be NULL eps.actual <- NULL if(is.null(dpar)) { descrip <- "(provided manually)" } else if(is.character(dmethod <- dpar$method)) { descrip <- dmethod } else if(identical(dpar$quasi, TRUE)) { descrip <- paste(npoints(D), "quasirandom dummy points", "plus 4 corner points") eps.actual <- 1/(2 * sqrt(intensity(D))) } else if(!is.null(nd <- dpar$nd)) { nd <- ensure2vector(nd) eps.actual <- unique(sidelengths(Frame(D))/nd) if(identical(dpar$random, TRUE)) { descrip <- paste("systematic random dummy points in", nd[1], "x", nd[2], "grid", "plus 4 corner points") } else { descrip <- paste(nd[1], "x", nd[2], "grid of dummy points, plus 4 corner points") } } else descrip <- "(rule for creating dummy points not understood)" if(!is.null(eps.actual)) { uD <- unitname(D) s$resolution <- numberwithunit(eps.actual, uD) if(!is.null(eps.given)) { descrip2 <- paste("dummy spacing:", format(eps.given %unit% uD), "requested,", format(eps.actual %unit% uD), "actual") } else { descrip2 <- paste("dummy spacing:", format(eps.actual %unit% uD)) } descrip <- c(descrip, descrip2) } s$descrip <- descrip w <- object$w Z <- is.data(object) s$w <- list(all = sumriz(w), data = sumriz(w[Z]), dummy = sumriz(w[!Z])) class(s) <- "summary.quad" return(s) } summary.quad }) print.summary.quad <- local({ summariseweights <- function(ww, blah, dp=3) { cat(paste(blah, ":\n\t", sep="")) if(is.null(ww)) { cat("(None)\n") return() } splat(paste0("range: ", "[", paste(signif(ww$range, digits=dp), collapse=", "), "]\t", "total: ", signif(ww$sum, digits=dp))) } print.summary.quad <- function(x, ..., dp=3) { splat("Quadrature scheme (Berman-Turner) = data + dummy + weights") pa <- x$param if(is.null(pa)) splat("created by an unknown function.") parbreak() splat("Data pattern:") print(x$data, dp=dp) parbreak() splat("Dummy quadrature points:") ## How they were computed splat(x$descrip, indent=5) parbreak() ## What arguments were given if(!is.null(orig <- pa$dummy$orig)) splat("Original dummy parameters:", paste0(names(orig), "=", orig, collapse=", ")) ## Description of the dummy points print(x$dummy, dp=dp) splat("Quadrature weights:") ## How they were computed if(!is.null(pa)) { wpar <- pa$weight if(is.null(wpar)) splat("(values provided manually)", indent=5) else if(is.character(wmethod <- wpar$method)) { switch(wmethod, grid = { splat("(counting weights based on", wpar$ntile[1], "x", wpar$ntile[2], "array of rectangular tiles)", indent=5) }, dirichlet = { splat("(Dirichlet tile areas, computed", if(wpar$exact) "exactly)" else "by pixel approximation)", indent=5) }, splat(wmethod, indent=5) ) } else splat("(rule for creating dummy points not understood)") } if(waxlyrical('extras')) { summariseweights(x$w$all, "All weights", dp) summariseweights(x$w$data, "Weights on data points", dp) summariseweights(x$w$dummy, "Weights on dummy points", dp) } return(invisible(NULL)) } print.summary.quad }) print.quad <- function(x, ...) { logi <- inherits(x, "logiquad") splat("Quadrature scheme", paren(if(logi) "logistic" else "Berman-Turner")) splat(x$data$n, "data points,", x$dummy$n, "dummy points") if(waxlyrical('extras')) { sx <- summary(x) splat(sx$descrip, indent=5) } splat("Total weight", sum(x$w), indent=5) return(invisible(NULL)) } spatstat.geom/R/diagram.R0000644000176200001440000003474114755302430015007 0ustar liggesusers## ## diagram.R ## ## Simple objects for the elements of a diagram (text, arrows etc) ## that are compatible with plot.layered and plot.solist ## ## $Revision: 1.19 $ $Date: 2025/02/19 07:13:33 $ # ......... internal class 'diagramobj' supports other classes ......... diagramobj <- function(X, ...) { if(inherits(try(Frame(X), silent=TRUE), "try-error")) stop("X is not a spatial object") a <- list(...) if(sum(nzchar(names(a))) != length(a)) stop("All extra arguments must be named") attributes(X) <- append(attributes(X), a) class(X) <- c("diagramobj", class(X)) return(X) } "[.diagramobj" <- function(x, ...) { y <- NextMethod("[") attributes(y) <- attributes(x) return(y) } # ... geometrical transformations .... affine.diagramobj <- function(X, ...) { y <- NextMethod("affine") attributes(y) <- attributes(X) return(y) } flipxy.diagramobj <- function(X) { y <- NextMethod("flipxy") attributes(y) <- attributes(X) return(y) } reflect.diagramobj <- function(X) { y <- NextMethod("reflect") attributes(y) <- attributes(X) return(y) } rotate.diagramobj <- function(X, ...) { y <- NextMethod("rotate") attributes(y) <- attributes(X) return(y) } scalardilate.diagramobj <- function(X, f, ...) { y <- NextMethod("scalardilate") attributes(y) <- attributes(X) return(y) } shift.diagramobj <- function(X, ...) { y <- NextMethod("shift") attributes(y) <- attributes(X) return(y) } # .............. user-accessible classes ................ # ......... (these only need a creator and a plot method) ...... ## ........... text ................. textstring <- function(x, y, txt=NULL, ...) { if(is.ppp(x) && missing(y)) { X <- x Window(X) <- boundingbox(x) } else { if(missing(y) && checkfields(x, c("x", "y"))) { y <- x$y x <- x$x stopifnot(length(x) == length(y)) } X <- ppp(x, y, window=owinInternalRect(range(x),range(y))) } marks(X) <- txt Y <- diagramobj(X, otherargs=list(...)) class(Y) <- c("textstring", class(Y)) return(Y) } plot.textstring <- function(x, ..., do.plot=TRUE) { txt <- marks(x) otha <- attr(x, "otherargs") if(do.plot) do.call.matched(text.default, resolve.defaults(list(...), list(x=x$x, y=x$y, labels=txt), otha), funargs=graphicsPars("text")) return(invisible(Frame(x))) } print.textstring <- function(x, ...) { splat("Text string object") txt <- marks(x) if(npoints(x) == 1) { splat("Text:", dQuote(txt)) splat("Coordinates:", paren(paste(as.vector(coords(x)), collapse=", "))) } else { splat("Text:") print(txt) splat("Coordinates:") print(coords(x)) } return(invisible(NULL)) } ## ........... 'yardstick' to display scale information ................ yardstick <- function(x0, y0, x1, y1, txt=NULL, ...) { nomore <- missing(y0) && missing(x1) && missing(y1) if(is.ppp(x0) && nomore) { if(npoints(x0) != 2) stop("x0 should consist of exactly 2 points") X <- x0 } else if(is.psp(x0) && nomore) { if(nobjects(x0) != 1) stop("x0 should consist of exactly 1 segment") X <- endpoints.psp(x0) } else { xx <- c(x0, x1) yy <- c(y0, y1) B <- boundingbox(list(x=xx, y=yy)) X <- ppp(xx, yy, window=B, check=FALSE) } Window(X) <- boundingbox(X) Y <- diagramobj(X, txt=txt, otherargs=list(...)) class(Y) <- c("yardstick", class(Y)) return(Y) } plot.yardstick <- local({ mysegments <- function(x0, y0, x1, y1, ..., moreargs=list()) { ## ignore unrecognised arguments without whingeing do.call.matched(segments, resolve.defaults(list(x0=x0, y0=y0, x1=x1, y1=y1), list(...), moreargs), extrargs=c("col", "lty", "lwd", "xpd", "lend")) } myarrows <- function(x0, y0, x1, y1, ..., left=TRUE, right=TRUE, angle=20, frac=0.25, main, show.all, add) { mysegments(x0, y0, x1, y1, ...) if(left || right) { ang <- angle * pi/180 co <- cos(ang) si <- sin(ang) dx <- x1-x0 dy <- y1-y0 le <- sqrt(dx^2 + dy^2) rot <- matrix(c(dx, dy, -dy, dx)/le, 2, 2) arlen <- frac * le up <- arlen * (rot %*% c(co, si)) lo <- arlen * (rot %*% c(co, -si)) if(left) { mysegments(x0, y0, x0+up[1L], y0+up[2L], ...) mysegments(x0, y0, x0+lo[1L], y0+lo[2L], ...) } if(right) { mysegments(x1, y1, x1-up[1L], y1-up[2L], ...) mysegments(x1, y1, x1-lo[1L], y1-lo[2L], ...) } } return(invisible(NULL)) } plot.yardstick <- function(x, ..., style=c("arrows", "zebra"), angle=20, frac=1/8, split=FALSE, shrink=1/4, zebra.step=NULL, zebra.width=NULL, zebra.col="black", pos=NULL, txt.args=list(), txt.shift=c(0,0), do.plot=TRUE) { style <- match.arg(style) if(do.plot) { txt <- attr(x, "txt") argh <- resolve.defaults(list(...), attr(x, "otherargs")) A <- as.numeric(coords(x)[1L,]) B <- as.numeric(coords(x)[2L,]) M <- (A+B)/2 if(is.null(txt.shift)) { txt.shift <- rep(0, 2) } else { txt.shift <- ensure2vector(unlist(txt.shift)) } switch(style, arrows = { if(!split) { ## double-headed arrow myarrows(A[1L], A[2L], B[1L], y1=B[2L], angle=angle, frac=frac, moreargs=argh) if(is.null(pos) && !("adj" %in% names(txt.args))) pos <- if(abs(A[1L] - B[1L]) < abs(A[2L] - B[2L])) 4 else 3 } else { ## two single-headed arrows with text dM <- (shrink/2) * (B - A) AM <- M - dM BM <- M + dM newfrac <- frac/((1-shrink)/2) myarrows(AM[1L], AM[2L], A[1L], A[2L], angle=angle, frac=newfrac, left=FALSE, moreargs=argh) myarrows(BM[1L], BM[2L], B[1L], B[2L], angle=angle, frac=newfrac, left=FALSE, moreargs=argh) } do.call.matched(text.default, resolve.defaults(list(x=M[1L] + txt.shift[1L], y=M[2L] + txt.shift[2L]), txt.args, list(labels=txt, pos=pos), argh, .MatchNull=FALSE), funargs=graphicsPars("text")) }, zebra = { ## total length and direction D <- B-A totlen <- sqrt(sum(D^2)) theta <- atan2(D[2L], D[1L]) ## length and width of each bar if(missing(zebra.step)) zebra.step <- totlen/5 if(missing(zebra.width)) zebra.width <- totlen/25 ## construct rectangles, then shift + rotate breaks <- seq(0, totlen, by=zebra.step) if(breaks[length(breaks)] < totlen * 0.95) breaks <- c(breaks, totlen) yr <- zebra.width * c(-1,1)/2 filled <- TRUE if(length(breaks) > 1) { for(i in 2:length(breaks)) { block <- owin(c(breaks[i-1], breaks[i]), yr) block <- rotate(shift(block, A), angle=theta, centre=M) if(filled) { plot(block, add=TRUE, col=zebra.col) } else { plot(block, add=TRUE, border=zebra.col) } vb <- vertices(block) x3 <- vb$x[3L] y3 <- vb$y[3L] do.call.matched(text.default, resolve.defaults(list(x=x3 + txt.shift[1L], y=y3 + txt.shift[2L]), txt.args, list(labels=breaks[i], pos=pos), argh, .MatchNull=FALSE), funargs=graphicsPars("text")) filled <- !filled } } }) } return(invisible(Window(x))) } plot.yardstick }) print.yardstick <- function(x, ...) { splat("Yardstick") if(!is.null(txt <- attr(x, "txt"))) splat("Text:", txt) ui <- summary(unitname(x)) splat("Length:", pairdist(x)[1L,2L], ui$plural, ui$explain) splat("Midpoint:", paren(paste(signif(c(mean(x$x), mean(x$y)), 3), collapse=", "))) dx <- diff(range(x$x)) dy <- diff(range(x$y)) orient <- if(dx == 0) "vertical" else if(dy == 0) "horizontal" else paste(atan2(dy, dx) * 180/pi, "degrees") splat("Orientation:", orient) return(invisible(NULL)) } ## ........... 'onearrow' .............................................. ## code to draw a decent-looking arrow in spatstat diagrams ## (works in layered objects) ## The name 'onearrow' is used because R contains ## hidden functions [.arrow, length.arrow onearrow <- function(x0, y0, x1, y1, txt=NULL, ...) { nomore <- missing(y0) && missing(x1) && missing(y1) if(is.ppp(x0) && nomore) { if(npoints(x0) != 2) stop("x0 should consist of exactly 2 points") X <- x0 } else if(is.psp(x0) && nomore) { if(nobjects(x0) != 1) stop("x0 should consist of exactly 1 segment") X <- endpoints.psp(x0) } else { xx <- c(x0, x1) yy <- c(y0, y1) B <- boundingbox(list(x=xx, y=yy)) X <- ppp(xx, yy, window=B, check=FALSE) } Window(X) <- boundingbox(X) Y <- diagramobj(X, txt=txt, otherargs=list(...)) class(Y) <- c("onearrow", class(Y)) return(Y) } print.onearrow <- function(x, ...) { splat("Single arrow from", paren(paste0(x$x[1], ", ", x$y[1])), "to", paren(paste0(x$x[2], ", ", x$y[2]))) if(!is.null(txt <- attr(x, "txt"))) splat("Text:", sQuote(txt)) if(length(oa <- attr(x, "otherargs"))) { cat("Graphical parameters:\n") print(unlist(oa)) } return(invisible(NULL)) } plot.onearrow <- function(x, ..., add=FALSE, main="", retract=0.05, headfraction=0.25, headangle=12, # degrees headnick=0.1, # fraction of head length col.head=NA, lwd.head=lwd, lwd=1, col=1, zap=FALSE, zapfraction=0.07, pch=1, cex=1, do.plot=TRUE, do.points=FALSE, show.all=!add) { result <- plot.ppp(x, main=main, add=add, pch=pch, cex=cex, do.plot=do.plot && do.points, show.all=show.all) if(do.plot && !do.points && !add) plot(Frame(x), main="", type="n") txt <- attr(x, "txt") ## resolve formal arguments with those stored in the object saved <- attr(x, "otherargs") if(missing(col)) col <- saved[["col"]] %orifnull% col if(missing(lwd)) lwd <- saved[["lwd"]] %orifnull% lwd if(missing(pch)) pch <- saved[["pch"]] %orifnull% pch if(missing(cex)) cex <- saved[["cex"]] %orifnull% cex if(missing(col.head)) col.head <- saved[["col.head"]] %orifnull% col.head if(missing(lwd.head)) lwd.head <- saved[["lwd.head"]] %orifnull% lwd.head if(missing(retract)) retract <- saved[["retract"]] %orifnull% retract if(missing(headfraction)) headfraction <- saved[["headfraction"]] %orifnull% headfraction if(missing(headangle)) headangle <- saved[["headangle"]] %orifnull% headangle if(missing(headnick)) headnick <- saved[["headnick"]] %orifnull% headnick if(missing(zap)) zap <- saved[["zap"]] %orifnull% zap if(missing(zapfraction)) zapfraction <- saved[["zapfraction"]] %orifnull% zapfraction argh <- list(col=col, lwd=lwd, cex=cex, pch=pch, ...) ## calculate A <- as.numeric(coords(x)[1L,]) B <- as.numeric(coords(x)[2L,]) V <- B - A AR <- A + retract * V BR <- B - retract * V H <- B - headfraction * V HN <- H + headnick * headfraction * V headlength <- headfraction * sqrt(sum(V^2)) halfwidth <- headlength * tan((headangle/2) * pi/180) alpha <- atan2(V[2L], V[1L]) + pi/2 U <- c(cos(alpha), sin(alpha)) HL <- H + halfwidth * U HR <- H - halfwidth * U Head <- rbind(HN, HR, BR, HL, HN) objHead <- owin(poly=Head[1:4,]) parHead <- resolve.defaults(list(col=col.head, lwd=lwd.head), argh) if(do.plot && !is.na(col.head)) do.call.matched(polygon, append(list(x=Head), parHead)) if(!zap) { Tail <- AR } else { M <- (AR+HN)/2 dM <- (zapfraction/2) * (1-headfraction) * V dM <- dM + c(-dM[2L], dM[1L]) ML <- M + dM MR <- M - dM Tail <- rbind(MR, ML, AR) } parLines <- argh if(do.plot) do.call.matched(lines, append(list(x=rbind(Head, Tail)), parLines), extrargs=c("col", "lwd", "lty", "xpd", "lend")) HT <- rbind(Head, Tail) W <- owinInternalRect(range(HT[,1]), range(HT[,2])) nht <- nrow(HT) HT <- cbind(HT[-nht, , drop=FALSE], HT[-1, , drop=FALSE]) objLines <- as.psp(HT, window=W) if(do.plot && !is.null(txt <- attr(x, "txt"))) { H <- (A+B)/2 do.call.matched(text.default, resolve.defaults( list(x=H[1L], y=H[2L]), argh, list(labels=txt, pos=3 + (V[2L] != 0))), funargs=graphicsPars("text")) } attr(result, "objects") <- layered(Head=objHead, Lines=objLines, plotargs=list(parHead, parLines)) return(invisible(result)) } spatstat.geom/R/transmat.R0000644000176200001440000000364414611065352015232 0ustar liggesusers## transmat.R ## ## transform matrices between different spatial indexing conventions ## ## $Revision: 1.1 $ $Date: 2015/03/04 07:13:10 $ transmat <- local({ euro <- matrix(c(0,-1,1,0), 2, 2) spat <- matrix(c(0,1,1,0), 2, 2) cart <- diag(c(1,1)) dimnames(euro) <- dimnames(spat) <- dimnames(cart) <- list(c("x","y"), c("i","j")) known <- list(spatstat=spat, cartesian=cart, Cartesian=cart, european=euro, European=euro) cmap <- list(x=c(1,0), y=c(0,1), i=c(1,0), j=c(0,1)) maptocoef <- function(s) { e <- parse(text=s)[[1]] eval(eval(substitute(substitute(f, cmap), list(f=e)))) } as.convention <- function(x) { if(is.character(x) && length(x) == 1) { k <- pmatch(x, names(known)) if(is.na(k)) stop(paste("Unrecognised convention", sQuote(x)), call.=FALSE) return(known[[k]]) } if(is.list(x) && is.character(unlist(x))) { xx <- lapply(x, maptocoef) if(all(c("x", "y") %in% names(xx))) z <- rbind(xx$x, xx$y) else if(all(c("i", "j") %in% names(xx))) z <- cbind(xx$x, xx$y) else stop("entries should be named i,j or x,y", call.=FALSE) dimnames(z) <- list(c("x","y"), c("i","j")) if(!(all(z == 0 | z == 1 | z == -1) && all(rowSums(abs(z)) == 1) && all(colSums(abs(z)) == 1))) stop("Illegal convention", call.=FALSE) return(z) } stop("Unrecognised format for spatial convention", call.=FALSE) } transmat <- function(m, from, to) { m <- as.matrix(m) from <- as.convention(from) to <- as.convention(to) conv <- solve(from) %*% to flip <- apply(conv == -1, 2, any) if(flip[["i"]]) m <- m[nrow(m):1, , drop=FALSE] if(flip[["j"]]) m <- m[ , ncol(m):1, drop=FALSE] if(all(diag(conv) == 0)) m <- t(m) return(m) } transmat }) spatstat.geom/R/distanxD.R0000644000176200001440000003125414611065351015154 0ustar liggesusers# # distanxD.R # # $Revision: 1.18 $ $Date: 2022/05/21 09:52:11 $ # # Interpoint distances for multidimensional points # # Methods for pairdist, nndist, nnwhich, crossdist # pairdist.ppx <- function(X, ...) { verifyclass(X, "ppx") # extract point coordinates coo <- as.matrix(coords(X, ...)) n <- nrow(coo) if(n == 0) return(matrix(numeric(0), nrow=0, ncol=0)) return(as.matrix(dist(coo))) } crossdist.ppx <- function(X, Y, ...) { verifyclass(X, "ppx") verifyclass(Y, "ppx") # extract point coordinates cooX <- as.matrix(coords(X, ...)) cooY <- as.matrix(coords(Y, ...)) nX <- nrow(cooX) nY <- nrow(cooY) if(ncol(cooX) != ncol(cooY)) stop("X and Y have different dimensions (different numbers of coordinates)") if(nX == 0 || nY == 0) return(matrix(numeric(0), nrow=nX, ncol=nY)) coo <- rbind(cooX, cooY) dis <- as.matrix(dist(coo)) ans <- dis[1:nX, nX + (1:nY)] return(ans) } genericNNdistBy <- function(X, by, k=1) { #' performs nndist(X, by) using generic nndist and nncross #' assuming they conform to the standard output format Y <- split(X, by) m <- length(Y) lev <- names(Y) blanklist <- vector(mode="list", length=m) partresults <- blanklist for(i in 1:m) { Yi <- Y[[i]] contrib <- blanklist for(j in 1:m) contrib[[j]] <- if(i == j) nndist(Yi, k=k) else nncross(Yi, Y[[j]], k=k, what="dist") names(contrib) <- lev partresults[[i]] <- do.call(cbind, contrib) } names(partresults) <- lev result <- as.data.frame(matrix(, npoints(X), m * length(k))) colnames(result) <- colnames(partresults[[1L]]) split(result, marks(X)) <- partresults return(result) } nndist.ppx <- function(X, ..., k=1, by=NULL) { verifyclass(X, "ppx") if(!is.null(by)) return(genericNNdistBy(X, by, k=k)) ## extract point coordinates coo <- as.matrix(coords(X, ...)) n <- nrow(coo) m <- ncol(coo) if(m == 0) { warning("nndist.ppx: Zero-dimensional coordinates: returning NA") if(length(k) == 1L) return(rep.int(NA_real_, n)) else return(matrix(NA_real_, n, length(k))) } # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1L) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } k <- as.integer(k) kmax <- max(k) # trivial cases if(n <= 1L) { # empty pattern => return numeric(0) # or pattern with only 1 point => return Inf nnd <- matrix(Inf, nrow=n, ncol=kmax) nnd <- nnd[,k, drop=TRUE] return(nnd) } # number of neighbours that are well-defined kmaxcalc <- min(n-1L, kmax) # calculate k-nn distances for k <= kmaxcalc if(kmaxcalc == 1L) { # calculate nearest neighbour distance only nnd<-numeric(n) o <- fave.order(coo[,1L]) big <- sqrt(.Machine$double.xmax) Cout <- .C(SG_nndMD, n= as.integer(n), m=as.integer(m), x= as.double(t(coo[o,])), nnd= as.double(nnd), as.double(big), PACKAGE="spatstat.geom") nnd[o] <- Cout$nnd } else { # case kmaxcalc > 1 nnd<-numeric(n * kmaxcalc) o <- fave.order(coo[,1L]) big <- sqrt(.Machine$double.xmax) Cout <- .C(SG_knndMD, n = as.integer(n), m = as.integer(m), kmax = as.integer(kmaxcalc), x = as.double(t(coo[o,])), nnd = as.double(nnd), huge = as.double(big), PACKAGE="spatstat.geom") nnd <- matrix(nnd, nrow=n, ncol=kmaxcalc) nnd[o, ] <- matrix(Cout$nnd, nrow=n, ncol=kmaxcalc, byrow=TRUE) } # post-processing if(kmax > kmaxcalc) { # add columns of Inf's infs <- matrix(as.numeric(Inf), nrow=n, ncol=kmax-kmaxcalc) nnd <- cbind(nnd, infs) } # add labels if(kmax > 1) colnames(nnd) <- paste0("dist.", 1:kmax) if(length(k) < kmax) { # select only the specified columns nnd <- nnd[, k, drop=TRUE] } return(nnd) } nnwhich.ppx <- function(X, ..., k=1) { verifyclass(X, "ppx") # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1L) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } k <- as.integer(k) kmax <- max(k) # extract point coordinates coo <- coords(X, ...) n <- nrow(coo) m <- ncol(coo) if(m == 0) { warning("nnwhich.ppx: Zero-dimensional coordinates: returning NA") if(length(k) == 1L) return(rep.int(NA_real_, n)) else return(matrix(NA_real_, n, length(k))) } # special cases if(n <= 1L) { # empty pattern => return integer(0) # or pattern with only 1 point => return NA nnw <- matrix(NA_integer_, nrow=n, ncol=kmax) nnw <- nnw[,k, drop=TRUE] return(nnw) } # number of neighbours that are well-defined kmaxcalc <- min(n-1L, kmax) # identify k-nn for k <= kmaxcalc if(kmaxcalc == 1L) { # identify nearest neighbour only nnw <- integer(n) o <- fave.order(coo[,1L]) big <- sqrt(.Machine$double.xmax) Cout <- .C(SG_nnwMD, n = as.integer(n), m = as.integer(m), x = as.double(t(coo[o,])), nnd = as.double(numeric(n)), nnwhich = as.integer(nnw), huge = as.double(big), PACKAGE="spatstat.geom") witch <- Cout$nnwhich if(any(witch <= 0)) stop("Internal error: non-positive index returned from C code") if(any(witch > n)) stop("Internal error: index returned from C code exceeds n") nnw[o] <- o[witch] } else { # case kmaxcalc > 1 nnw <- matrix(integer(n * kmaxcalc), nrow=n, ncol=kmaxcalc) o <- fave.order(coo[,1L]) big <- sqrt(.Machine$double.xmax) Cout <- .C(SG_knnwMD, n = as.integer(n), m = as.integer(m), kmax = as.integer(kmaxcalc), x = as.double(t(coo[o,])), nnd = as.double(numeric(n * kmaxcalc)), nnwhich = as.integer(nnw), huge = as.double(big), PACKAGE="spatstat.geom") witch <- Cout$nnwhich witch <- matrix(witch, nrow=n, ncol=kmaxcalc, byrow=TRUE) if(any(witch <= 0)) stop("Internal error: non-positive index returned from C code") if(any(witch > n)) stop("Internal error: index returned from C code exceeds n") # convert back to original ordering nnw[o,] <- matrix(o[witch], nrow=n, ncol=kmaxcalc) } # post-processing if(kmax > kmaxcalc) { # add columns of NA's nas <- matrix(NA_integer_, nrow=n, ncol=kmax-kmaxcalc) nnw <- cbind(nnw, nas) } if(kmax > 1) colnames(nnw) <- paste0("which.", 1:kmax) if(length(k) < kmax) { # select only the specified columns nnw <- nnw[, k, drop=TRUE] } return(nnw) } nncross.ppx <- function(X, Y, iX=NULL, iY=NULL, what = c("dist", "which"), ..., k = 1) { verifyclass(X, "ppx") verifyclass(Y, "ppx") what <- match.arg(what, several.ok=TRUE) want.dist <- "dist" %in% what want.which <- "which" %in% what ## k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1L) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } k <- as.integer(k) kmax <- max(k) nk <- length(k) ## extract point coordinates cooX <- as.matrix(coords(X, ...)) nX <- nrow(cooX) m <- ncol(cooX) cooY <- as.matrix(coords(Y, ...)) nY <- nrow(cooY) mY <- ncol(cooY) ## check dimensions if(mY != m) stop(paste("Point patterns have different spatial dimensions:", m, "!=", mY), call.=FALSE) if(m == 0) { warning("nncross.ppx: Zero-dimensional coordinates: returning NA") if(nk == 1L) { NND <- if(want.dist) rep.int(NA_real_, nX) else 0 NNW <- if(want.which) rep.int(NA_integer_, nX) else 0 } else { NND <- if(want.dist) matrix(NA_real_, nX, nk) else 0 NNW <- if(want.which) matrix(NA_integer_, nX, nk) else 0 } return(packupNNdata(NND, NNW, what, k)) } ## trivial cases if(nX == 0L || nY == 0L) { NND <- matrix(Inf, nrow=nX, ncol=nk) NNW <- matrix(NA_integer_, nrow=nX, ncol=nk) return(packupNNdata(NND, NNW, what, k)) } ## exclusion arguments if(is.null(iX) != is.null(iY)) stop("If one of iX, iY is given, then both must be given") exclude <- (!is.null(iX) || !is.null(iY)) if(exclude) { stopifnot(is.integer(iX) && is.integer(iY)) if(length(iX) != nX) stop("length of iX does not match the number of points in X") if(length(iY) != nY) stop("length of iY does not match the number of points in Y") } ## number of neighbours that are well-defined kmaxcalc <- min(nY, kmax) ## find k-nearest neighbours for k <= kmaxcalc oX <- fave.order(cooX[,1L]) oY <- fave.order(cooY[,1L]) big <- sqrt(.Machine$double.xmax) if(kmaxcalc == 1L) { ## find nearest neighbour only nnd <- numeric(nX) nnw <- integer(nX) if(!exclude) { Cout <- .C(SG_nnXwMD, m =as.integer(m), n1 = as.integer(nX), x1 = as.double(t(cooX[oX,])), n2 = as.integer(nY), x2 = as.double(t(cooY[oY,])), nnd = as.double(nnd), nnwhich = as.integer(nnw), as.double(big), PACKAGE="spatstat.geom") } else { Cout <- .C(SG_nnXxMD, m =as.integer(m), n1 = as.integer(nX), x1 = as.double(t(cooX[oX,])), id1 = as.integer(iX[oX]), n2 = as.integer(nY), x2 = as.double(t(cooY[oY,])), id2 = as.integer(iY[oY]), nnd = as.double(nnd), nnwhich = as.integer(nnw), as.double(big), PACKAGE="spatstat.geom") } if(want.dist) nnd[oX] <- Cout$nnd if(want.which) { witch <- Cout$nnwhich if(any(witch <= 0)) stop("Internal error: non-positive index returned from C code") if(any(witch > nY)) stop("Internal error: index returned from C code exceeds npoints(Y)") nnw[oX] <- oY[witch] } } else { ## k-nearest nnd <- matrix(0, nX, kmaxcalc) nnw <- matrix(0L, nX, kmaxcalc) if(!exclude) { Cout <- .C(SG_knnXwMD, m = as.integer(m), n1 = as.integer(nX), x1 = as.double(t(cooX[oX,])), n2 = as.integer(nY), x2 = as.double(t(cooY[oY,])), kmax = as.integer(kmaxcalc), nnd = as.double(nnd), nnwhich = as.integer(nnw), huge = as.double(big), PACKAGE="spatstat.geom") } else { Cout <- .C(SG_knnXxMD, m = as.integer(m), n1 = as.integer(nX), x1 = as.double(t(cooX[oX,])), id1 = as.integer(iX[oX]), n2 = as.integer(nY), x2 = as.double(t(cooY[oY,])), id2 = as.integer(iY[oY]), kmax = as.integer(kmaxcalc), nnd = as.double(nnd), nnwhich = as.integer(nnw), huge = as.double(big), PACKAGE="spatstat.geom") } dust <- Cout$nnd witch <- Cout$nnwhich if(any(notfound <- (witch <= 0 | witch > nY))) { dust[notfound] <- Inf witch[notfound] <- NA } nnd[oX, ] <- matrix(dust, nrow=nX, ncol=kmaxcalc, byrow=TRUE) nnw[oX, ] <- matrix(oY[witch], nrow=nX, ncol=kmaxcalc, byrow=TRUE) } ## post-processing if(kmax > kmaxcalc) { ## add columns of Inf's/NA's if(want.dist) { infs <- matrix(as.numeric(Inf), nrow=nX, ncol=kmax-kmaxcalc) nnd <- cbind(nnd, infs) } if(want.which) { nas <- matrix(NA_integer_, nrow=nX, ncol=kmax-kmaxcalc) nnw <- cbind(nnw, nas) } } if(length(k) < kmax) { ## select only the specified columns if(want.dist) nnd <- nnd[, k, drop=TRUE] if(want.which) nnw <- nnw[, k, drop=TRUE] } return(packupNNdata(nnd, nnw, what, k)) } spatstat.geom/R/distan3D.R0000644000176200001440000002075114611065351015047 0ustar liggesusers# # distan3D.R # # $Revision: 1.15 $ $Date: 2022/05/21 09:52:11 $ # # Interpoint distances for 3D points # # Methods for pairdist, nndist, nnwhich, crossdist # pairdist.pp3 <- function(X, ..., periodic=FALSE, squared=FALSE) { verifyclass(X, "pp3") # extract point coordinates xyz <- coords(X) n <- nrow(xyz) x <- xyz$x y <- xyz$y z <- xyz$z # # special cases if(n == 0) return(matrix(numeric(0), nrow=0, ncol=0)) else if(n == 1L) return(matrix(0,nrow=1L,ncol=1L)) # if(!periodic) { Cout <- .C(SG_D3pairdist, n = as.integer(n), x = as.double(x), y = as.double(y), z = as.double(z), squared = as.integer(squared), d = as.double(numeric(n*n)), PACKAGE="spatstat.geom") } else { b <- as.box3(X) wide <- diff(b$xrange) high <- diff(b$yrange) deep <- diff(b$zrange) Cout <- .C(SG_D3pairPdist, n = as.integer(n), x = as.double(x), y = as.double(y), z = as.double(z), xwidth=as.double(wide), yheight=as.double(high), zdepth=as.double(deep), squared = as.integer(squared), d= as.double(numeric(n*n)), PACKAGE="spatstat.geom") } dout <- matrix(Cout$d, nrow=n, ncol=n) return(dout) } nndist.pp3 <- function(X, ..., k=1, by=NULL) { verifyclass(X, "pp3") if((narg <- length(list(...))) > 0) warning(paste(narg, "unrecognised", ngettext(narg, "argument was", "arguments were"), "ignored")) if(!is.null(by)) return(genericNNdistBy(X, by, k=k)) # extract point coordinates xyz <- coords(X) n <- nrow(xyz) x <- xyz$x y <- xyz$y z <- xyz$z # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1L) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } k <- as.integer(k) kmax <- max(k) # trivial cases if(n <= 1L) { # empty pattern => return numeric(0) # or pattern with only 1 point => return Inf nnd <- matrix(Inf, nrow=n, ncol=kmax) nnd <- nnd[,k, drop=TRUE] return(nnd) } # number of neighbours that are well-defined kmaxcalc <- min(n-1L, kmax) # calculate k-nn distances for k <= kmaxcalc if(kmaxcalc == 1L) { # calculate nearest neighbour distance only nnd<-numeric(n) o <- fave.order(z) big <- sqrt(.Machine$double.xmax) Cout <- .C(SG_nnd3D, n= as.integer(n), x= as.double(x[o]), y= as.double(y[o]), z= as.double(z[o]), nnd= as.double(nnd), nnwhich = as.integer(integer(1L)), huge=as.double(big), PACKAGE="spatstat.geom") nnd[o] <- Cout$nnd } else { # case kmaxcalc > 1 nnd<-numeric(n * kmaxcalc) o <- fave.order(z) big <- sqrt(.Machine$double.xmax) Cout <- .C(SG_knnd3D, n = as.integer(n), kmax = as.integer(kmaxcalc), x = as.double(x[o]), y = as.double(y[o]), z = as.double(z[o]), nnd = as.double(nnd), nnwhich = as.integer(integer(1L)), huge = as.double(big), PACKAGE="spatstat.geom") nnd <- matrix(nnd, nrow=n, ncol=kmaxcalc) nnd[o, ] <- matrix(Cout$nnd, nrow=n, ncol=kmaxcalc, byrow=TRUE) } # post-processing if(kmax > kmaxcalc) { # add columns of Inf's infs <- matrix(as.numeric(Inf), nrow=n, ncol=kmax-kmaxcalc) nnd <- cbind(nnd, infs) } if(length(k) < kmax) { # select only the specified columns nnd <- nnd[, k, drop=TRUE] } return(nnd) } nnwhich.pp3 <- function(X, ..., k=1) { verifyclass(X, "pp3") if((narg <- length(list(...))) > 0) warning(paste(narg, "unrecognised", ngettext(narg, "argument was", "arguments were"), "ignored")) # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1L) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } k <- as.integer(k) kmax <- max(k) # extract point coordinates xyz <- coords(X) n <- nrow(xyz) x <- xyz$x y <- xyz$y z <- xyz$z # special cases if(n <= 1L) { # empty pattern => return integer(0) # or pattern with only 1 point => return NA nnw <- matrix(as.integer(NA), nrow=n, ncol=kmax) nnw <- nnw[,k, drop=TRUE] return(nnw) } # number of neighbours that are well-defined kmaxcalc <- min(n-1L, kmax) # identify k-nn for k <= kmaxcalc if(kmaxcalc == 1L) { # identify nearest neighbour only nnw <- integer(n) o <- fave.order(z) big <- sqrt(.Machine$double.xmax) Cout <- .C(SG_nnw3D, n = as.integer(n), x = as.double(x[o]), y = as.double(y[o]), z = as.double(z[o]), nnd = as.double(numeric(1L)), nnwhich = as.integer(nnw), huge = as.double(big), PACKAGE="spatstat.geom") # [sic] Conversion from C to R indexing is done in C code. witch <- Cout$nnwhich if(any(witch <= 0)) stop("Internal error: illegal index returned from C code") if(any(witch > n)) stop("Internal error: index returned from C code exceeds n") nnw[o] <- o[witch] } else { # case kmaxcalc > 1 nnw <- matrix(integer(n * kmaxcalc), nrow=n, ncol=kmaxcalc) o <- fave.order(z) big <- sqrt(.Machine$double.xmax) Cout <- .C(SG_knnw3D, n = as.integer(n), kmax = as.integer(kmaxcalc), x = as.double(x[o]), y = as.double(y[o]), z = as.double(z[o]), nnd = as.double(numeric(1L)), nnwhich = as.integer(nnw), huge = as.double(big), PACKAGE="spatstat.geom") # [sic] Conversion from C to R indexing is done in C code. witch <- Cout$nnwhich witch <- matrix(witch, nrow=n, ncol=kmaxcalc, byrow=TRUE) if(any(witch <= 0)) stop("Internal error: illegal index returned from C code") if(any(witch > n)) stop("Internal error: index returned from C code exceeds n") # convert back to original ordering nnw[o,] <- matrix(o[witch], nrow=n, ncol=kmaxcalc) } # post-processing if(kmax > kmaxcalc) { # add columns of NA's nas <- matrix(as.integer(NA), nrow=n, ncol=kmax-kmaxcalc) nnw <- cbind(nnw, nas) } if(length(k) < kmax) { # select only the specified columns nnw <- nnw[, k, drop=TRUE] } return(nnw) } crossdist.pp3 <- function(X, Y, ..., periodic=FALSE, squared=FALSE) { verifyclass(X, "pp3") verifyclass(Y, "pp3") cX <- coords(X) cY <- coords(Y) nX <- nrow(cX) nY <- nrow(cY) if(nX == 0 || nY == 0) return(matrix(numeric(0), nrow=nX, ncol=nY)) if(!periodic) { Cout <- .C(SG_D3crossdist, nfrom = as.integer(nX), xfrom = as.double(cX$x), yfrom = as.double(cX$y), zfrom = as.double(cX$z), nto = as.integer(nY), xto = as.double(cY$x), yto = as.double(cY$y), zto = as.double(cY$z), squared = as.integer(squared), d = as.double(matrix(0, nrow=nX, ncol=nY)), PACKAGE="spatstat.geom") } else { b <- as.box3(X) wide <- diff(b$xrange) high <- diff(b$yrange) deep <- diff(b$zrange) Cout <- .C(SG_D3crossPdist, nfrom = as.integer(nX), xfrom = as.double(cX$x), yfrom = as.double(cX$y), zfrom = as.double(cX$z), nto = as.integer(nY), xto = as.double(cY$x), yto = as.double(cY$y), zto = as.double(cY$z), xwidth = as.double(wide), yheight = as.double(high), zheight = as.double(deep), squared = as.integer(squared), d = as.double(matrix(0, nrow=nX, ncol=nY)), PACKAGE="spatstat.geom") } return(matrix(Cout$d, nrow=nX, ncol=nY)) } spatstat.geom/R/colourschemes.R0000644000176200001440000000546214611065351016253 0ustar liggesusers# # colourschemes.R # # $Revision: 1.6 $ $Date: 2023/02/18 03:50:13 $ # beachcolourmap <- function(range, ...) { col <- beachcolours(range, ...) z <- colourmap(col, range=range) return(z) } beachcolours <- function(range, sealevel = 0, monochrome=FALSE, ncolours=if(monochrome) 16 else 64, nbeach=1) { check.range(range) stopifnot(all(is.finite(range))) check.1.real(sealevel) range <- range(c(sealevel,range)) check.1.integer(ncolours) stopifnot(ncolours >= 3) check.1.integer(nbeach) stopifnot(nbeach >= 0) stopifnot(nbeach <= ncolours + 2) if(monochrome) return(grey(seq(from=0,to=1,length.out=ncolours))) depths <- range[1L] peaks <- range[2L] dv <- diff(range)/(ncolours - 1L) epsilon <- nbeach * dv/2 lowtide <- max(sealevel - epsilon, depths) hightide <- min(sealevel + epsilon, peaks) nsea <- max(0L, floor((lowtide - depths)/dv)) nland <- max(0L, floor((peaks - hightide)/dv)) discrep <- nsea + nland + nbeach - ncolours if(discrep != 0) { dd <- abs(discrep) ss <- as.integer(-sign(discrep)) smallhalf <- dd/2L largehalf <- dd - smallhalf if(nsea < nland) { nsea <- nsea + ss * smallhalf nland <- nland + ss * largehalf } else { nland <- nland + ss * smallhalf nsea <- nsea + ss * largehalf } if(nsea + nland + nbeach != ncolours) warning("Internal error: incorrect adjustment of length in beachcolours") } colours <- character(0) if(nsea > 0) colours <- rev(rainbow(nsea, start=3/6,end=4/6)) # cyan/blue if(nbeach > 0) colours <- c(colours, rev(rainbow(nbeach, start=3/12,end=5/12))) # green if(nland > 0) colours <- c(colours, rev(rainbow(nland, start=0, end=1/6))) # red/yellow return(colours) } pHcolour <- function(pH) { ## Defined mapping from pH values to hues ## rescale pH from [0, 14] to [0,1] ff <- pH/14 bad <- (ff < 0) | (ff > 1) ff <- pmax(0, pmin(1, ff)) ## contract towards 0.5 ee <- 2*ff - 1 tt <- 0.5 + 0.5 * sign(ee) * sqrt(abs(ee)) tt <- pmax(0, pmin(1, tt)) * 2/3 hu <- hsv(h=tt) hu[bad] <- NA return(hu) } pHcolourmap <- function(range=c(0, 14), ..., n=256, step=FALSE) { check.range(range) if(!step) { ## continuous colours xx <- seq.int(from=range[1], to=range[2], length.out=n) co <- pHcolour(xx) phmap <- colourmap(co, range=range) } else { ## colours jump at integer pH ## first make a map with integer range intbreaks <- (floor(range[1])):(ceiling(range[2])) midvals <- intbreaks[-1] - 0.5 midcols <- pHcolour(midvals) phmap <- colourmap(midcols, breaks=intbreaks) ## now trim the range if(any(range %% 1 != 0)) { phmap <- restrict.colourmap(phmap, range=range) } } return(phmap) } spatstat.geom/R/close3Dpairs.R0000644000176200001440000002016214611065351015725 0ustar liggesusers# # close3Dpairs.R # # $Revision: 1.18 $ $Date: 2022/06/15 01:29:04 $ # # extract the r-close pairs from a 3D dataset # # closepairs.pp3 <- local({ closepairs.pp3 <- function(X, rmax, twice=TRUE, what=c("all", "indices", "ijd"), distinct=TRUE, neat=TRUE, ...) { verifyclass(X, "pp3") what <- match.arg(what) stopifnot(is.numeric(rmax) && length(rmax) == 1L) stopifnot(is.finite(rmax)) stopifnot(rmax >= 0) ordered <- list(...)$ordered if(missing(twice) && !is.null(ordered)) { warning("Obsolete argument 'ordered' has been replaced by 'twice'") twice <- ordered } npts <- npoints(X) nama <- switch(what, all = c("i", "j", "xi", "yi", "zi", "xj", "yj", "zj", "dx", "dy", "dz", "d"), indices = c("i", "j"), ijd = c("i", "j", "d")) names(nama) <- nama if(npts == 0) { null.answer <- lapply(nama, nuttink) return(null.answer) } ## sort points by increasing x coordinate oo <- fave.order(coords(X)$x) Xsort <- X[oo] ## First make an OVERESTIMATE of the number of pairs nsize <- list(...)$nsize # secret option to test overflow code if(!is.null(nsize)) { splat("Using nsize =", nsize) } else { #' normal usage npairs <- as.double(npts)^2 if(npairs <= 1024) { nsize <- 1024 } else { catchfraction <- (4/3) * pi * (rmax^3)/volume(as.box3(X)) nsize <- ceiling(4 * catchfraction * npairs) nsize <- min(nsize, npairs) nsize <- max(1024, nsize) if(nsize > .Machine$integer.max) { warning( "Estimated number of close pairs exceeds maximum possible integer", call.=FALSE) nsize <- .Machine$integer.max } } } ## Now extract pairs XsortC <- coords(Xsort) x <- XsortC$x y <- XsortC$y z <- XsortC$z r <- rmax ng <- nsize storage.mode(x) <- "double" storage.mode(y) <- "double" storage.mode(z) <- "double" storage.mode(r) <- "double" storage.mode(ng) <- "integer" ## go a <- switch(what, all = { .Call(SG_close3pairs, xx=x, yy=y, zz=z, rr=r, nguess=ng, PACKAGE="spatstat.geom") }, indices = { .Call(SG_close3IJpairs, xx=x, yy=y, zz=z, rr=r, nguess=ng, PACKAGE="spatstat.geom") }, ijd = { .Call(SG_close3IJDpairs, xx=x, yy=y, zz=z, rr=r, nguess=ng, PACKAGE="spatstat.geom") }) names(a) <- nama ## convert i,j indices to original sequence a$i <- oo[a$i] a$j <- oo[a$j] ## handle options if(twice) { ## both (i, j) and (j, i) should be returned a <- as.data.frame(a) a <- as.list(rbind(a, swapdata(a, what))) } else if(neat) { ## enforce i < j swap <- with(a, (j < i)) if(any(swap)) { a <- as.data.frame(a) a[swap,] <- swapdata(a[swap, ,drop=FALSE], what) a <- as.list(a) } } ## add pairs of identical points? if(!distinct) { ii <- seq_len(npts) xtra <- switch(what, indices = { data.frame(i = ii, j=ii) }, ijd= { data.frame(i = ii, j=ii, d=0) }, all = { cooi <- cooj <- coords(X)[, c("x","y","z")] names(cooi) <- c("xi", "yi", "zi") names(cooj) <- c("xj", "yj", "zj") zero <- numeric(npts) cbind(data.frame(i=ii, j=ii), cooi, cooj, data.frame(dx=zero, dy=zero, dz=zero, d=zero)) }) a <- as.list(rbind(as.data.frame(a), xtra)) } ## done return(a) } swapdata <- function(a, what) { switch(what, all = { with(a, data.frame(i = j, j = i, xi = xj, yi = yj, zi = zj, xj = xi, yj = yi, zj = zi, dx = -dx, dy = -dy, dz = -dz, d = d)) }, indices = { with(a, data.frame(i=j, j=i)) }, ijd = { with(a, data.frame(i=j, j=i, d=d)) }) } nuttink <- function(x) numeric(0) closepairs.pp3 }) ####################### crosspairs.pp3 <- local({ crosspairs.pp3 <- function(X, Y, rmax, what=c("all", "indices", "ijd"), ...) { verifyclass(X, "pp3") verifyclass(Y, "pp3") what <- match.arg(what) stopifnot(is.numeric(rmax) && length(rmax) == 1L && rmax >= 0) nama <- switch(what, all = c("i", "j", "xi", "yi", "zi", "xj", "yj", "zj", "dx", "dy", "dz", "d"), indices = c("i", "j"), ijd = c("i", "j", "d")) names(nama) <- nama nX <- npoints(X) nY <- npoints(Y) if(nX == 0 || nY == 0) { null.answer <- lapply(nama, nuttink) return(null.answer) } ## order patterns by increasing x coordinate ooX <- fave.order(coords(X)$x) Xsort <- X[ooX] ooY <- fave.order(coords(Y)$x) Ysort <- Y[ooY] ## First (over)estimate the number of pairs nsize <- list(...)$nsize # secret option to test overflow code if(!is.null(nsize)) { splat("Using nsize =", nsize) } else { #' normal usage nXY <- as.double(nX) * as.double(nY) if(nXY <= 1024) { nsize <- 1024 } else { catchfraction <- (4/3) * pi * (rmax^3)/volume(as.box3(Y)) nsize <- ceiling(4 * catchfraction * nXY) nsize <- min(nXY, nsize) nsize <- max(1024, nsize) if(nsize > .Machine$integer.max) { warning( "Estimated number of close pairs exceeds maximum possible integer", call.=FALSE) nsize <- .Machine$integer.max } } } ## .Call XsortC <- coords(Xsort) YsortC <- coords(Ysort) Xx <- XsortC$x Xy <- XsortC$y Xz <- XsortC$z Yx <- YsortC$x Yy <- YsortC$y Yz <- YsortC$z r <- rmax ng <- nsize storage.mode(Xx) <- storage.mode(Xy) <- storage.mode(Xz) <- "double" storage.mode(Yx) <- storage.mode(Yy) <- storage.mode(Yz) <- "double" storage.mode(r) <- "double" storage.mode(ng) <- "integer" ## go a <- switch(what, all = { .Call(SG_cross3pairs, xx1=Xx, yy1=Xy, zz1=Xz, xx2=Yx, yy2=Yy, zz2=Yz, rr=r, nguess=ng, PACKAGE="spatstat.geom") }, indices = { .Call(SG_cross3IJpairs, xx1=Xx, yy1=Xy, zz1=Xz, xx2=Yx, yy2=Yy, zz2=Yz, rr=r, nguess=ng, PACKAGE="spatstat.geom") }, ijd = { .Call(SG_cross3IJDpairs, xx1=Xx, yy1=Xy, zz1=Xz, xx2=Yx, yy2=Yy, zz2=Yz, rr=r, nguess=ng, PACKAGE="spatstat.geom") }) names(a) <- nama ## convert i,j indices to original sequence a$i <- ooX[a$i] a$j <- ooY[a$j] return(a) } nuttink <- function(x) numeric(0) crosspairs.pp3 }) spatstat.geom/R/psp.R0000644000176200001440000005070114633444363014206 0ustar liggesusers# # psp.R # # $Revision: 1.116 $ $Date: 2024/06/16 02:06:24 $ # # Class "psp" of planar line segment patterns # # ################################################# # creator ################################################# psp <- function(x0, y0, x1, y1, window, marks=NULL, check=spatstat.options("checksegments")) { stopifnot(is.numeric(x0)) stopifnot(is.numeric(y0)) stopifnot(is.numeric(x1)) stopifnot(is.numeric(y1)) stopifnot(is.vector(x0)) stopifnot(is.vector(y0)) stopifnot(is.vector(x1)) stopifnot(is.vector(y1)) stopifnot(length(x0) == length(y0)) stopifnot(length(x1) == length(y1)) stopifnot(length(x0) == length(x1)) ends <- data.frame(x0=x0,y0=y0,x1=x1,y1=y1) if(!missing(window)) verifyclass(window,"owin") if(check) { ok <- inside.owin(x0,y0, window) & inside.owin(x1,y1,window) if((nerr <- sum(!ok)) > 0) stop(paste(nerr, ngettext(nerr, "segment does not", "segments do not"), "lie entirely inside the window.\n"), call.=FALSE) } out <- list(ends=ends, window=window, n = nrow(ends)) # add marks if any if(!is.null(marks)) { if(is.matrix(marks)) marks <- as.data.frame(marks) if(is.data.frame(marks)) { omf <- "dataframe" nmarks <- nrow(marks) rownames(marks) <- seq_len(nmarks) whinge <- "The number of rows of marks" } else { omf <- "vector" names(marks) <- NULL nmarks <- length(marks) whinge <- "The length of the marks vector" } if(nmarks != out$n) stop(paste(whinge, "!= length of x and y.\n")) out$marks <- marks out$markformat <- omf } else { out$markformat <- "none" } class(out) <- c("psp", class(out)) return(out) } ###################################################### # conversion ###################################################### is.psp <- function(x) { inherits(x, "psp") } as.psp <- function(x, ..., from=NULL, to=NULL) { # special case: two point patterns if(is.null(from) != is.null(to)) stop(paste("If one of", sQuote("from"), "and", sQuote("to"), "is specified, then both must be specified.\n")) if(!is.null(from) && !is.null(to)) { verifyclass(from, "ppp") verifyclass(to, "ppp") if(from$n != to$n) stop(paste("The point patterns", sQuote("from"), "and", sQuote("to"), "have different numbers of points.\n")) uni <- union.owin(from$window, to$window) fromx <- from$x fromy <- from$y tox <- to$x toy <- to$y dont.complain.about(fromx, fromy, tox, toy) Y <- do.call(psp, resolve.defaults(list(quote(fromx), quote(fromy), quote(tox), quote(toy)), list(...), list(window=uni))) return(Y) } UseMethod("as.psp") } as.psp.psp <- function(x, ..., check=FALSE, fatal=TRUE) { if(!verifyclass(x, "psp", fatal=fatal)) return(NULL) ends <- x$ends psp(ends$x0, ends$y0, ends$x1, ends$y1, window=x$window, marks=x$marks, check=check) } as.psp.data.frame <- function(x, ..., window=NULL, marks=NULL, check=spatstat.options("checksegments"), fatal=TRUE) { window <- suppressWarnings(as.owin(window,fatal=FALSE)) if(!is.owin(window)) { if(fatal) stop("Cannot interpret \"window\" as an object of class owin.\n") return(NULL) } if(checkfields(x, "marks")) { if(is.null(marks)) marks <- x$marks else warning(paste("Column named \"marks\" ignored;\n", "argument named \"marks\" has precedence.\n",sep="")) x$marks <- NULL } if(checkfields(x, c("x0", "y0", "x1", "y1"))) { out <- psp(x$x0, x$y0, x$x1, x$y1, window=window, check=check) x <- x[-match(c("x0","y0","x1","y1"),names(x))] } else if(checkfields(x, c("xmid", "ymid", "length", "angle"))) { rr <- x$length/2 dx <- cos(x$angle) * rr dy <- sin(x$angle) * rr bb <- boundingbox(window) rmax <- max(rr) bigbox <- owinInternalRect(bb$xrange + c(-1,1) * rmax, bb$yrange + c(-1,1) * rmax) pattern <- psp(x$xmid - dx, x$ymid - dy, x$xmid + dx, x$ymid + dy, window=bigbox,check=FALSE) out <- pattern[window] x <- x[-match(c("xmid","ymid","length","angle"),names(x))] } else if(ncol(x) >= 4) { out <- psp(x[,1], x[,2], x[,3], x[,4], window=window, check=check) x <- x[-(1:4)] } else { ## data not understood if(fatal) stop("Unable to interpret x as a line segment pattern.", call.=FALSE) return(NULL) } if(ncol(x) > 0) { #' additional columns of mark data in 'x' if(is.null(marks)) { marks <- x } else { warning(paste("Additional columns in x were ignored", "because argument 'marks' takes precedence"), call.=FALSE) } } if(!is.null(marks)) { #' SUPPRESSED: if(identical(ncol(marks), 1L)) marks <- marks[,1L] #' assign marks directly to avoid infinite recursion out$marks <- marks out$markformat <- markformat(marks) } return(out) } as.psp.matrix <- function(x, ..., window=NULL, marks=NULL, check=spatstat.options("checksegments"), fatal=TRUE) { x <- as.data.frame(x) as.psp(x,...,window=window,marks=marks,check=check,fatal=fatal) } as.psp.default <- function(x, ..., window=NULL, marks=NULL, check=spatstat.options("checksegments"), fatal=TRUE) { if(checkfields(x,"marks")) { if(is.null(marks)) marks <- x$marks else warning(paste("Component of \"x\" named \"marks\" ignored;\n", "argument named \"marks\" has precedence.\n",sep="")) } if(checkfields(x, c("x0", "y0", "x1", "y1"))) return(psp(x$x0, x$y0, x$x1, x$y1, window=window, marks=marks, check=check)) else if(checkfields(x, c("xmid", "ymid", "length", "angle"))) { rr <- x$length/2 dx <- cos(x$angle) * rr dy <- sin(x$angle) * rr window <- as.owin(window) bb <- boundingbox(window) rmax <- max(rr) bigbox <- owinInternalRect(bb$xrange + c(-1,1) * rmax, bb$yrange + c(-1,1) * rmax) pattern <- psp(x$x - dx, x$y - dy, x$x + dx, x$y + dy, window=bigbox, marks=marks, check=FALSE) clipped <- pattern[window] return(clipped) } else if(fatal) stop("Unable to interpret x as a line segment pattern") return(NULL) } as.psp.owin <- function(x, ..., window=NULL, check=spatstat.options("checksegments"), fatal=TRUE) { .Deprecated("edges", package="spatstat.geom") edges(x, ..., window=window, check=check) } edges <- function(x, ..., window=NULL, check=FALSE) { x <- as.owin(x) if(is.null(window)) window <- as.rectangle(x) x <- as.polygonal(x) x0 <- y0 <- x1 <- y1 <- numeric(0) bdry <- x$bdry for(i in seq_along(bdry)) { po <- bdry[[i]] ni <- length(po$x) nxt <- c(2:ni, 1) x0 <- c(x0, po$x) y0 <- c(y0, po$y) x1 <- c(x1, po$x[nxt]) y1 <- c(y1, po$y[nxt]) } out <- psp(x0, y0, x1, y1, window=window, check=check) return(out) } xypolygon2psp <- function(p, w, check=spatstat.options("checksegments")) { verify.xypolygon(p) n <- length(p$x) nxt <- c(2:n, 1) return(psp(p$x, p$y, p$x[nxt], p$y[nxt], window=w, check=check)) } ################# as.data.frame.psp <- function(x, row.names=NULL, ...) { df <- as.data.frame(x$ends, row.names=row.names) if(is.marked(x)) df <- cbind(df, if(x$markformat=="dataframe") marks(x) else data.frame(marks=marks(x))) return(df) } ####### manipulation ########################## append.psp <- function(A,B) { if(is.null(A) && (is.psp(B) || is.null(B))) return(B) if(is.null(B) && is.psp(A)) return(A) verifyclass(A, "psp") verifyclass(B, "psp") stopifnot(identical(A$window, B$window)) marks <- marks(A) %mapp% marks(B) ends <- rbind(A$ends, B$ends) out <- as.psp(ends,window=A$window,marks=marks,check=FALSE) return(out) } rebound.psp <- function(x, rect) { verifyclass(x, "psp") x$window <- rebound.owin(x$window, rect) return(x) } ################################################# # marks ################################################# is.marked.psp <- function(X, ...) { marx <- marks(X, ...) return(!is.null(marx)) } marks.psp <- function(x, ..., dfok = TRUE) { # data frames of marks are as of 19/March 2011 implemented for psp ma <- x$marks if ((is.data.frame(ma) || is.matrix(ma)) && !dfok) stop("Sorry, not implemented when the marks are a data frame.\n") return(ma) } "marks<-.psp" <- function(x, ..., value) { stopifnot(is.psp(x)) if(is.null(value)) return(unmark(x)) m <- value if(is.hyperframe(m)) stop("Hyperframes of marks are not supported in psp objects.\n") if(!(is.vector(m) || is.factor(m) || is.data.frame(m) || is.matrix(m))) stop("Incorrect format for marks") nseg <- nsegments(x) if (!is.data.frame(m) && !is.matrix(m)) { ## vector/factor if (length(m) == 1) m <- rep.int(m, nseg) else if (nseg == 0) m <- rep.int(m, 0) else if (length(m) != nseg) stop("Number of marks != number of line segments.\n") marx <- m } else { ## multiple columns m <- as.data.frame(m) if (ncol(m) == 0) { marx <- NULL } else if (nrow(m) == nseg) { marx <- m } else if (nrow(m) == 1 || nseg == 0) { marx <- as.data.frame(lapply(as.list(m), rep.int, times=nseg)) } else stop("Number of rows of data frame != number of line segments") } Y <- as.psp(x$ends, window = x$window, marks = marx, check = FALSE) return(Y) } markformat.psp <- function(x) { x$markformat %orifnull% markformat(marks(x)) } unmark.psp <- function(X) { X$marks <- NULL X$markformat <- "none" return(X) } print.psp <- function(x, ...) { verifyclass(x, "psp") n <- x$n ism <- is.marked(x, dfok = TRUE) splat(if(ism) "marked" else NULL, "planar line segment pattern:", n, ngettext(n, "line segment", "line segments")) if(ism) { mks <- marks(x, dfok = TRUE) if(is.data.frame(mks)) { splat("Mark variables: ", paste(names(mks), collapse = ", ")) } else { if(is.factor(mks)) { splat("multitype, with levels =", paste(levels(mks), collapse = "\t")) } else { splat("marks are", if(is.numeric(mks)) "numeric," else NULL, "of type", sQuote(typeof(mks))) } } } print(x$window) return(invisible(NULL)) } unitname.psp <- function(x) { return(unitname(x$window)) } "unitname<-.psp" <- function(x, value) { w <- x$window unitname(w) <- value x$window <- w return(x) } #################################################### # summary information #################################################### endpoints.psp <- function(x, which="both") { verifyclass(x, "psp") ends <- x$ends n <- x$n switch(which, both={ first <- second <- rep.int(TRUE, n) }, first={ first <- rep.int(TRUE, n) second <- rep.int(FALSE, n) }, second={ first <- rep.int(FALSE, n) second <- rep.int(TRUE, n) }, left={ first <- (ends$x0 < ends$x1) second <- !first }, right={ first <- (ends$x0 > ends$x1) second <- !first }, lower={ first <- (ends$y0 < ends$y1) second <- !first }, upper={ first <- (ends$y0 > ends$y1) second <- !first }, stop(paste("Unrecognised option: which=", sQuote(which))) ) ok <- rbind(first, second) xmat <- rbind(ends$x0, ends$x1) ymat <- rbind(ends$y0, ends$y1) idmat <- col(ok) xx <- as.vector(xmat[ok]) yy <- as.vector(ymat[ok]) id <- as.vector(idmat[ok]) result <- ppp(xx, yy, window=x$window, check=FALSE) attr(result, "id") <- id return(result) } midpoints.psp <- function(x) { verifyclass(x, "psp") xm <- eval(expression((x0+x1)/2), envir=x$ends) ym <- eval(expression((y0+y1)/2), envir=x$ends) win <- x$window ok <- inside.owin(xm, ym, win) if(any(!ok)) { warning(paste("Some segment midpoints lie outside the original window;", "window replaced by bounding box")) win <- boundingbox(win) } ppp(x=xm, y=ym, window=win, check=FALSE) } lengths_psp <- function(x, squared=FALSE) { verifyclass(x, "psp") lengths2 <- eval(expression((x1-x0)^2 + (y1-y0)^2), envir=x$ends) return(if(squared) lengths2 else sqrt(lengths2)) } angles.psp <- function(x, directed=FALSE) { verifyclass(x, "psp") a <- eval(expression(atan2(y1-y0, x1-x0)), envir=x$ends) if(!directed) a <- a %% pi return(a) } summary.psp <- function(object, ...) { verifyclass(object, "psp") len <- lengths_psp(object) out <- list(n = object$n, len = summary(len), totlen = sum(len), ang= summary(angles.psp(object)), w = summary.owin(object$window), marks=if(is.null(object$marks)) NULL else summary(object$marks), unitinfo=summary(unitname(object))) class(out) <- c("summary.psp", class(out)) return(out) } print.summary.psp <- function(x, ...) { cat(paste(x$n, "line segments\n")) cat("Lengths:\n") print(x$len) unitblurb <- paste(x$unitinfo$plural, x$unitinfo$explain) cat(paste("Total length:", x$totlen, unitblurb, "\n")) cat(paste("Length per unit area:", x$totlen/x$w$area, "\n")) cat("Angles (radians):\n") print(x$ang) print(x$w) if(!is.null(x$marks)) { cat("Marks:\n") print(x$marks) } return(invisible(NULL)) } extrapolate.psp <- function(x, ...) { verifyclass(x, "psp") theta <- (angles.psp(x) + pi/2) %% (2*pi) p <- with(x$ends, x1*cos(theta) + y1 * sin(theta)) result <- infline(p=p, theta=theta) return(result) } ######################################################## # subsets ######################################################## "[.psp" <- function(x, i, j, drop, ..., fragments=TRUE) { verifyclass(x, "psp") if(missing(i) && missing(j)) return(x) if(!missing(i)) { style <- if(inherits(i, "owin")) "window" else "index" switch(style, window={ x <- clip.psp(x, window=i, check=FALSE, fragments=fragments) }, index={ enz <- x$ends[i, ] win <- x$window marx <- marksubset(x$marks, i, markformat(x)) x <- with(enz, psp(x0, y0, x1, y1, window=win, marks=marx, check=FALSE)) }) } if(!missing(j)) x <- x[j] # invokes code above return(x) } #################################################### # affine transformations #################################################### affine.psp <- function(X, mat=diag(c(1,1)), vec=c(0,0), ...) { verifyclass(X, "psp") W <- affine.owin(X$window, mat=mat, vec=vec, ...) E <- X$ends ends0 <- affinexy(list(x=E$x0,y=E$y0), mat=mat, vec=vec) ends1 <- affinexy(list(x=E$x1,y=E$y1), mat=mat, vec=vec) psp(ends0$x, ends0$y, ends1$x, ends1$y, window=W, marks=marks(X, dfok=TRUE), check=FALSE) } shift.psp <- function(X, vec=c(0,0), ..., origin=NULL) { verifyclass(X, "psp") W <- Window(X) if(!is.null(origin)) { if(!missing(vec)) warning("argument vec ignored; argument origin has precedence") locn <- interpretAsOrigin(origin, W) vec <- -locn } # perform shift W <- shift.owin(W, vec=vec, ...) E <- X$ends ends0 <- shiftxy(list(x=E$x0,y=E$y0), vec=vec, ...) ends1 <- shiftxy(list(x=E$x1,y=E$y1), vec=vec, ...) Y <- psp(ends0$x, ends0$y, ends1$x, ends1$y, window=W, marks=marks(X, dfok=TRUE), check=FALSE) # tack on shift vector attr(Y, "lastshift") <- vec return(Y) } rotate.psp <- function(X, angle=pi/2, ..., centre=NULL) { verifyclass(X, "psp") if(!is.null(centre)) { X <- shift(X, origin=centre) negorigin <- getlastshift(X) } else negorigin <- NULL W <- rotate.owin(X$window, angle=angle, ...) E <- X$ends ends0 <- rotxy(list(x=E$x0,y=E$y0), angle=angle) ends1 <- rotxy(list(x=E$x1,y=E$y1), angle=angle) Y <- psp(ends0$x, ends0$y, ends1$x, ends1$y, window=W, marks=marks(X, dfok=TRUE), check=FALSE) if(!is.null(negorigin)) Y <- shift(Y, -negorigin) return(Y) } is.empty.psp <- function(x) { return(x$n == 0) } identify.psp <- function(x, ..., labels=seq_len(nsegments(x)), n=nsegments(x), plot=TRUE) { if(dev.cur() == 1 && interactive()) { eval(substitute(plot(X), list(X=substitute(x)))) } Y <- x B <- Frame(Y) Bplus <- grow.rectangle(B, max(sidelengths(B))/4) mids <- midpoints.psp(Y) poz <- c(1, 2, 4, 3)[(floor(angles.psp(Y)/(pi/4)) %% 4) + 1L] gp <- if(plot) graphicsPars("lines") else NULL if(!(is.numeric(n) && (length(n) == 1) && (n %% 1 == 0) && (n >= 0))) stop("n should be a single integer") out <- integer(0) while(length(out) < n) { xy <- spatstatLocator(1, type="n") ## check for interrupt exit if(length(xy$x) == 0) return(out) ## find nearest segment X <- ppp(xy$x, xy$y, window=Bplus) ident <- project2segment(X, Y)$mapXY if(length(ident) == 0) { cat("Query location is too far away\n") } else if(ident %in% out) { cat(paste("Segment", ident, "already selected\n")) } else { ## add to list if(plot) { ## Display mi <- mids[ident] li <- labels[ident] po <- poz[ident] mix <- mi$x miy <- mi$y dont.complain.about(li, mix, miy) do.call.matched(graphics::text.default, resolve.defaults(list(x=quote(mix), y=quote(miy), labels=quote(li)), list(...), list(pos=po))) do.call.matched(plot.psp, resolve.defaults(list(x=Y[ident], add=TRUE), list(...), list(col="blue", lwd=2)), extrargs=gp) } out <- c(out, ident) } } ## exit if max n reached return(out) } nsegments <- function(x) { UseMethod("nsegments") } nobjects.psp <- nsegments.psp <- function(x) { x$n } as.ppp.psp <- function (X, ..., fatal=TRUE) { Y <- endpoints.psp(X, which="both") m <- marks(X) marks(Y) <- markappend(m, m) return(Y) } domain.psp <- Window.psp <- function(X, ...) { as.owin(X) } "Window<-.psp" <- function(X, ..., value) { verifyclass(value, "owin") X[value] } edit.psp <- function(name, ...) { x <- name y <- edit(as.data.frame(x), ...) xnew <- as.psp(y, window=Window(x)) return(xnew) } text.psp <- function(x, ...) { mids <- midpoints.psp(x) poz <- c(1, 2,4, 3)[(floor(angles.psp(x)/(pi/4)) %% 4) + 1L] midx <- mids$x midy <- mids$y dont.complain.about(midx, midy) do.call.matched(graphics::text.default, resolve.defaults(list(x=quote(midx), y=quote(midy)), list(...), list(pos=poz), .StripNull=TRUE)) return(invisible(NULL)) } intensity.psp <- function(X, ..., weights=NULL) { len <- lengths_psp(X) a <- area(Window(X)) if(is.null(weights)) { ## unweighted case - for efficiency if(is.multitype(X)) { mks <- marks(X) answer <- tapply(len, mks, sum)/a answer[is.na(answer)] <- 0 names(answer) <- levels(mks) } else answer <- sum(len)/a return(answer) } ## weighted case if(is.numeric(weights)) { check.nvector(weights, nsegments(X), things="segments", vname="weights") } else if(is.expression(weights)) { # evaluate expression in data frame of coordinates and marks df <- as.data.frame(X) pf <- parent.frame() eval.weights <- try(eval(weights, envir=df, enclos=pf)) if(inherits(eval.weights, "try-error")) stop("Unable to evaluate expression for weights", call.=FALSE) if(!check.nvector(eval.weights, nsegments(X), fatal=FALSE, warn=TRUE, vname="eval(weights)")) stop("Result of evaluating the expression for weights has wrong format") weights <- eval.weights } else stop("Unrecognised format for argument 'weights'") ## if(is.multitype(X)) { mks <- marks(X) answer <- as.vector(tapply(weights * len, mks, sum))/a answer[is.na(answer)] <- 0 names(answer) <- levels(mks) } else { answer <- sum(weights)/a } return(answer) } spatstat.geom/R/triangulate.R0000644000176200001440000000156614611065352015721 0ustar liggesusers#' #' triangulate.R #' #' Decompose a polygon into triangles #' #' $Revision: 1.4 $ $Date: 2015/11/21 11:13:00 $ #' triangulate.owin <- local({ is.triangle <- function(p) { return((length(p$bdry) == 1) && (length(p$bdry[[1]]$x) == 3)) } triangulate.owin <- function(W) { stopifnot(is.owin(W)) W <- as.polygonal(W, repair=TRUE) P <- as.ppp(vertices(W), W=Frame(W), check=FALSE) D <- delaunay(P) V <- intersect.tess(W, D) Candidates <- tiles(V) istri <- sapply(Candidates, is.triangle) Accepted <- Candidates[istri] if(any(!istri)) { # recurse Worries <- unname(Candidates[!istri]) Fixed <- lapply(Worries, triangulate.owin) Fixed <- do.call(c, lapply(Fixed, tiles)) Accepted <- append(Accepted, Fixed) } result <- tess(tiles=Accepted, window=W) return(result) } triangulate.owin }) spatstat.geom/R/applynbd.R0000644000176200001440000000514514611065351015207 0ustar liggesusers# applynbd.R # # $Revision: 1.20 $ $Date: 2022/06/09 01:30:00 $ # # applynbd() # For each point, identify either # - all points within distance R # - the closest N points # - those points satisfying some constraint # and apply the function FUN to them # # markstat() # simple application of applynbd ################################################################# applynbd <- function(X, FUN, N=NULL, R=NULL, criterion=NULL, exclude=FALSE, ...) { if(is.null(N) && is.null(R) && is.null(criterion)) stop(paste("must specify at least one of the arguments", commasep(sQuote(c("N","R","criterion"))))) if(!inherits(X, c("ppp", "lpp", "pp3", "ppx"))) X <- as.ppp(X) npts <- npoints(X) # compute matrix of pairwise distances dist <- pairdist(X) # compute row ranks (avoid ties) rankit <- function(x) { u <- numeric(length(x)); u[fave.order(x)] <- seq_along(x); return(u) } drank <- t(apply(dist, 1L, rankit)) - 1L included <- matrix(TRUE, npts, npts) if(!is.null(R)) { # select points closer than R included <- included & (dist <= R) } if(!is.null(N)) { # select N closest points if(N < 1) stop("Value of N must be at least 1") if(exclude) included <- included & (drank <= N) else included <- included & (drank <= N-1) } if(!is.null(criterion)) { # some funny criterion for(i in 1L:npts) included[i,] <- included[i,] & criterion(dist[i,], drank[i,]) } if(exclude) diag(included) <- FALSE # bind into an array a <- array(c(included, dist, drank, row(included)), dim=c(npts,npts,4)) # what to do with a[i, , ] if(!is.marked(X)) go <- function(ai, Z, fun, ...) { which <- as.logical(ai[,1L]) distances <- ai[,2L] dranks <- ai[,3L] here <- ai[1L,4L] fun(Y=Z[which], current=as.list(coords(Z[here])), dists=distances[which], dranks=dranks[which], ...) } else go <- function(ai, Z, fun, ...) { which <- as.logical(ai[,1L]) distances <- ai[,2L] dranks <- ai[,3L] here <- ai[1L,4L] fun(Y=Z[which], current=Z[here], dists=distances[which], dranks=dranks[which], ...) } # do it result <- apply(a, 1, go, Z=X, fun=FUN, ...) return(result) } markstat <- function(X, fun, N=NULL, R=NULL, ...) { if(!inherits(X, c("ppp", "lpp", "pp3", "ppx"))) X <- as.ppp(X) stopifnot(is.function(fun)) statfun <- function(Y, current, dists, dranks, func, ...) { func(marks(Y, dfok=TRUE), ...) } applynbd(X, statfun, R=R, N=N, func=fun, ...) } spatstat.geom/R/psp2pix.R0000644000176200001440000000700214611065352014776 0ustar liggesusers# # psp2pix.R # # $Revision: 1.16 $ $Date: 2023/05/04 00:58:27 $ # # psp2mask <- as.mask.psp <- function(x, W=NULL, ...) { L <- as.psp(x) if(is.null(W)) W <- as.owin(L) else W <- as.owin(W) W <- do.call.matched(as.mask, resolve.defaults(list(...), list(w=quote(W)))) ends <- L$ends nseg <- nrow(ends) if(nseg == 0) { # empty W$m[] <- FALSE return(W) } x0 <- (ends$x0 - W$xrange[1])/W$xstep x1 <- (ends$x1 - W$xrange[1])/W$xstep y0 <- (ends$y0 - W$yrange[1])/W$ystep y1 <- (ends$y1 - W$yrange[1])/W$ystep nr <- W$dim[1] nc <- W$dim[2] zz <- .C(SG_seg2pixI, ns=as.integer(nseg), x0=as.double(x0), y0=as.double(y0), x1=as.double(x1), y1=as.double(y1), nx=as.integer(nc), ny=as.integer(nr), out=as.integer(integer(nr * nc)), PACKAGE="spatstat.geom") mm <- matrix(zz$out, nr, nc) # intersect with existing window W$m <- W$m & mm W } pixellate.psp <- function(x, W=NULL, ..., weights=NULL, what=c("length", "number"), DivideByPixelArea=FALSE) { L <- as.psp(x) what <- match.arg(what) if(is.null(W)) W <- as.owin(L) else W <- as.owin(W) W <- do.call.matched(as.mask, resolve.defaults(list(...), list(w=quote(W)))) Z <- as.im(W) ends <- L$ends nseg <- nrow(ends) if(nseg == 0) { # empty Z$v[] <- 0 return(Z) } if(is.null(weights)) weights <- rep.int(1, nseg) else { if(!is.numeric(weights)) stop("weights must be numeric") if(anyNA(weights)) stop("weights must not be NA") if(!all(is.finite(weights))) stop("weights must not be infinite") if(length(weights) == 1) weights <- rep.int(weights, nseg) else if(length(weights) != nseg) stop(paste("weights vector has length", length(weights), "but there are", nseg, "line segments")) } x0 <- (ends$x0 - Z$xrange[1])/Z$xstep x1 <- (ends$x1 - Z$xrange[1])/Z$xstep y0 <- (ends$y0 - Z$yrange[1])/Z$ystep y1 <- (ends$y1 - Z$yrange[1])/Z$ystep nr <- Z$dim[1] nc <- Z$dim[2] switch(what, length = { zz <- .C(SG_seg2pixL, ns=as.integer(nseg), x0=as.double(x0), y0=as.double(y0), x1=as.double(x1), y1=as.double(y1), weights=as.double(weights), pixwidth=as.double(Z$xstep), pixheight=as.double(Z$ystep), nx=as.integer(nc), ny=as.integer(nr), out=as.double(numeric(nr * nc)), PACKAGE="spatstat.geom") }, number = { zz <- .C(SG_seg2pixN, ns=as.integer(nseg), x0=as.double(x0), y0=as.double(y0), x1=as.double(x1), y1=as.double(y1), w=as.double(weights), nx=as.integer(nc), ny=as.integer(nr), out=as.double(numeric(nr * nc)), PACKAGE="spatstat.geom") }) mm <- matrix(zz$out, nr, nc) ## intersect with existing window mm[is.na(Z$v)] <- NA ## if(DivideByPixelArea) { pixelarea <- W$xstep * W$ystep mm <- mm/pixelarea } ## pack up Z$v <- mm return(Z) } spatstat.geom/R/nncross3D.R0000644000176200001440000001604214611065352015251 0ustar liggesusers# # nncross3D.R # # $Revision: 1.11 $ $Date: 2022/05/21 09:52:11 $ # # Copyright (C) Adrian Baddeley, Jens Oehlschlaegel and Rolf Turner 2000-2013 # Licence: GNU Public Licence >= 2 nncross.pp3 <- function(X, Y, iX=NULL, iY=NULL, what = c("dist", "which"), ..., k = 1, sortby=c("range", "var", "x", "y", "z"), is.sorted.X = FALSE, is.sorted.Y = FALSE) { stopifnot(is.pp3(Y)) sortby <- match.arg(sortby) what <- match.arg(what, choices=c("dist", "which"), several.ok=TRUE) want.dist <- "dist" %in% what want.which <- "which" %in% what want.both <- want.dist && want.which if(!missing(k)) { # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } } k <- as.integer(k) kmax <- max(k) nk <- length(k) # trivial cases nX <- npoints(X) nY <- nobjects(Y) # deal with null cases if(nX == 0) return(as.data.frame(list(dist=matrix(0, nrow=0, ncol=nk), which=matrix(0L, nrow=0, ncol=nk))[what])) if(nY == 0) return(as.data.frame(list(dist=matrix(Inf, nrow=nX, ncol=nk), which=matrix(NA, nrow=nX, ncol=nk))[what])) if(is.null(iX) != is.null(iY)) stop("If one of iX, iY is given, then both must be given") exclude <- (!is.null(iX) || !is.null(iY)) if(exclude) { stopifnot(is.integer(iX) && is.integer(iY)) if(length(iX) != nX) stop("length of iX does not match the number of points in X") if(length(iY) != nY) stop("length of iY does not match the number of points in Y") } if((is.sorted.X || is.sorted.Y) && !(sortby %in% c("x", "y", "z"))) stop(paste("If data are already sorted,", "the sorting coordinate must be specified explicitly", "using sortby = \"x\" or \"y\" or \"z\"")) # decide which coordinate to sort on switch(sortby, range = { s <- sidelengths(as.box3(Y)) sortcoord <- c("x", "y", "z")[which.min(s)] }, var = { v <- apply(coords(Y), 2, var) sortcoord <- c("x", "y", "z")[which.min(v)] }, x={ sortcoord <- "x" }, y={ sortcoord <- "y" }, z={ sortcoord <- "z" } ) # The C code expects points to be sorted by z coordinate. XX <- coords(X) YY <- coords(Y) switch(sortcoord, x = { # rotate x axis to z axis XX <- XX[, c(3,2,1)] YY <- YY[, c(3,2,1)] }, y = { # rotate y axis to z axis XX <- XX[, c(3,1,2)] YY <- YY[, c(3,1,2)] }, z = { }) # sort only if needed if(!is.sorted.X){ oX <- fave.order(XX[,3]) XX <- XX[oX, , drop=FALSE] if(exclude) iX <- iX[oX] } if (!is.sorted.Y){ oY <- fave.order(YY[,3]) YY <- YY[oY, , drop=FALSE] if(exclude) iY <- iY[oY] } # number of neighbours that are well-defined kmaxcalc <- min(nY, kmax) if(kmaxcalc == 1) { # ............... single nearest neighbour .................. # call C code nndv <- if(want.dist) numeric(nX) else numeric(1) nnwh <- if(want.which) integer(nX) else integer(1) if(!exclude) iX <- iY <- integer(1) huge <- 1.1 * diameter(bounding.box3(as.box3(X),as.box3(Y))) z <- .C(SG_nnX3Dinterface, n1=as.integer(nX), x1=as.double(XX[,1]), y1=as.double(XX[,2]), z1=as.double(XX[,3]), id1=as.integer(iX), n2=as.integer(nY), x2=as.double(YY[,1]), y2=as.double(YY[,2]), z2=as.double(YY[,3]), id2=as.integer(iY), exclude = as.integer(exclude), wantdist = as.integer(want.dist), wantwhich = as.integer(want.which), nnd=as.double(nndv), nnwhich=as.integer(nnwh), huge=as.double(huge), PACKAGE="spatstat.geom") if(want.which) { # conversion to R indexing is done in C code nnwcode <- z$nnwhich if(any(uhoh <- (nnwcode == 0))) { warning("Internal error: NA's produced in nncross()$which") nnwcode[uhoh] <- NA } } # reinterpret in original ordering if(is.sorted.X){ if(want.dist) nndv <- z$nnd if(want.which) nnwh <- if(is.sorted.Y) nnwcode else oY[nnwcode] } else { if(want.dist) nndv[oX] <- z$nnd if(want.which) nnwh[oX] <- if(is.sorted.Y) nnwcode else oY[nnwcode] } if(want.both) return(data.frame(dist=nndv, which=nnwh)) return(if(want.dist) nndv else nnwh) } else { # ............... k nearest neighbours .................. # call C code nndv <- if(want.dist) numeric(nX * kmaxcalc) else numeric(1) nnwh <- if(want.which) integer(nX * kmaxcalc) else integer(1) if(!exclude) iX <- iY <- integer(1) huge <- 1.1 * diameter(bounding.box3(as.box3(X),as.box3(Y))) z <- .C(SG_knnX3Dinterface, n1=as.integer(nX), x1=as.double(XX[,1]), y1=as.double(XX[,2]), z1=as.double(XX[,3]), id1=as.integer(iX), n2=as.integer(nY), x2=as.double(YY[,1]), y2=as.double(YY[,2]), z2=as.double(YY[,3]), id2=as.integer(iY), kmax=as.integer(kmaxcalc), exclude = as.integer(exclude), wantdist = as.integer(want.dist), wantwhich = as.integer(want.which), nnd=as.double(nndv), nnwhich=as.integer(nnwh), huge=as.double(huge), PACKAGE="spatstat.geom") # extract results nnD <- z$nnd nnW <- z$nnwhich # map 0 to NA if(want.which && any(uhoh <- (nnW == 0))) { nnW[uhoh] <- NA if(want.dist) nnD[uhoh] <- Inf } # reinterpret indices in original ordering if(!is.sorted.Y) nnW <- oY[nnW] # reform as matrices NND <- if(want.dist) matrix(nnD, nrow=nX, ncol=kmaxcalc, byrow=TRUE) else 0 NNW <- if(want.which) matrix(nnW, nrow=nX, ncol=kmaxcalc, byrow=TRUE) else 0 if(!is.sorted.X){ # rearrange rows to correspond to original ordering of points if(want.dist) NND[oX, ] <- NND if(want.which) NNW[oX, ] <- NNW } # the return value should correspond to the original vector k if(kmax > kmaxcalc) { # add columns of NA / Inf kextra <- kmax - kmaxcalc if(want.dist) NND <- cbind(NND, matrix(Inf, nrow=nX, ncol=kextra)) if(want.which) NNW <- cbind(NNW, matrix(NA_integer_, nrow=nX, ncol=kextra)) } if(length(k) < kmax) { # select only the specified columns if(want.dist) NND <- NND[, k, drop=TRUE] if(want.which) NNW <- NNW[, k, drop=TRUE] } result <- packupNNdata(NND, NNW, what, k) return(result) } } spatstat.geom/R/setcov.R0000644000176200001440000000641514611065352014703 0ustar liggesusers# # # setcov.R # # $Revision: 1.17 $ $Date: 2024/02/04 08:04:51 $ # # Compute the set covariance function of a window # or the (noncentred) spatial covariance function of an image # setcov <- function(W, V=W, ...) { W <- as.owin(W) # pixel approximation mW <- as.mask(W, ...) Z <- as.im(mW, na.replace=0) if(missing(V)) return(imcov(Z)) # cross-covariance V <- as.owin(V) mV <- as.mask(V, ...) Z2 <- as.im(mV, na.replace=0) imcov(Z, Z2) } imcov <- function(X, Y=X) { if(missing(Y)) Y <- NULL convolve.im(X, Y, reflectX = FALSE, reflectY=TRUE) } convolve.im <- function(X, Y=X, ..., reflectX=FALSE, reflectY=FALSE) { stopifnot(is.im(X)) have.Y <- !missing(Y) && !is.null(Y) crosscov <- have.Y || reflectX || reflectY trap.extra.arguments(..., .Context="In convolve.im") #' Check whether Fastest Fourier Transform in the West is available west <- fftwAvailable() #' if(have.Y) { # cross-covariance stopifnot(is.im(Y)) Xbox <- as.rectangle(X) Ybox <- as.rectangle(Y) # first shift images to common midpoint, to reduce storage Xmid <- centroid.owin(Xbox) Ymid <- centroid.owin(Ybox) svec <- as.numeric(Xmid) - as.numeric(Ymid) Y <- shift(Y, svec) # ensure images are compatible XY <- harmonise.im(X=X, Y=Y) X <- XY$X Y <- XY$Y } else { # Y is missing or NULL Y <- X Xbox <- Ybox <- as.rectangle(X) } M <- X$v M[is.na(M)] <- 0 xstep <- X$xstep ystep <- X$ystep # pad with zeroes nr <- nrow(M) nc <- ncol(M) Mpad <- matrix(0, ncol=2*nc, nrow=2*nr) Mpad[1:nr, 1:nc] <- M lengthMpad <- 4 * nc * nr fM <- fft2D(Mpad, west=west) if(!crosscov) { # compute convolution square G <- fft2D(fM^2, inverse=TRUE, west=west)/lengthMpad } else { # compute set cross-covariance or convolution by FFT N <- Y$v N[is.na(N)] <- 0 Npad <- matrix(0, ncol=2*nc, nrow=2*nr) Npad[1:nr, 1:nc] <- N fN <- fft2D(Npad, west=west) if(reflectY) fN <- Conj(fN) if(reflectX) fM <- Conj(fM) G <- fft2D(fM * fN, inverse=TRUE, west=west)/lengthMpad } # cat(paste("maximum imaginary part=", max(Im(G)), "\n")) G <- Mod(G) * xstep * ystep if(reflectX != reflectY) { # Currently G[i,j] corresponds to a vector shift of # dy = (i-1) mod nr, dx = (j-1) mod nc. # Rearrange this periodic function so that # the origin of translations (0,0) is at matrix position (nr,nc) # NB this introduces an extra row and column G <- G[ ((-nr):nr) %% (2 * nr) + 1, (-nc):nc %% (2*nc) + 1] } # Determine spatial domain of full raster image XB <- as.rectangle(X) YB <- as.rectangle(Y) # undo shift if(have.Y) YB <- shift(YB, -svec) # reflect if(reflectX) XB <- reflect(XB) if(reflectY) YB <- reflect(YB) # Minkowski sum of covering boxes xran <- XB$xrange + YB$xrange yran <- XB$yrange + YB$yrange # Declare spatial domain out <- im(G, xrange = xran, yrange=yran) if(crosscov) { # restrict to actual spatial domain of function if(reflectX) Xbox <- reflect(Xbox) if(reflectY) Ybox <- reflect(Ybox) # Minkowski sum xran <- Xbox$xrange + Ybox$xrange yran <- Xbox$yrange + Ybox$yrange XYbox <- owinInternalRect(xran, yran) out <- out[XYbox, rescue=TRUE] } unitname(out) <- unitname(X) return(out) } spatstat.geom/R/deltametric.R0000644000176200001440000000136714611065351015675 0ustar liggesusers# # deltametric.R # # Delta metric # # $Revision: 1.5 $ $Date: 2022/01/04 05:30:06 $ # deltametric <- function(A, B, p=2, c=Inf, ...) { stopifnot(is.numeric(p) && length(p) == 1L && p > 0) # ensure frames are identical bb <- boundingbox(as.rectangle(A), as.rectangle(B)) # enforce identical frames A <- rebound(A, bb) B <- rebound(B, bb) # compute distance functions dA <- distmap(A, ...) dB <- distmap(B, ...) if(!is.infinite(c)) { dA <- eval.im(pmin.int(dA, c)) dB <- eval.im(pmin.int(dB, c)) } if(is.infinite(p)) { # L^infinity Z <- eval.im(abs(dA-dB)) delta <- summary(Z)$max } else { # L^p Z <- eval.im(abs(dA-dB)^p) iZ <- summary(Z)$mean delta <- iZ^(1/p) } return(delta) } spatstat.geom/R/aaa.R0000644000176200001440000000071314611065351014114 0ustar liggesusers#' #' aaa.R #' #' Code that must be read before the rest of the R code in spatstat.geom #' #' $Revision: 1.2 $ $Date: 2023/02/28 03:36:53 $ .spEnv <- new.env() putSpatstatVariable <- function(name, value) { assign(name, value, envir=.spEnv) } getSpatstatVariable <- function(name, default=NULL) { if(exists(name, envir=.spEnv)) get(name, envir=.spEnv) else default } existsSpatstatVariable <- function(name) { exists(name, envir=.spEnv) } spatstat.geom/R/affine.R0000644000176200001440000003176114612610733014632 0ustar liggesusers# # affine.R # # $Revision: 1.58 $ $Date: 2024/04/26 02:29:54 $ # affinexy <- function(X, mat=diag(c(1,1)), vec=c(0,0), invert=FALSE) { if(length(X$x) == 0 && length(X$y) == 0) return(list(x=numeric(0),y=numeric(0))) if(invert) { mat <- invmat <- solve(mat) vec <- - as.numeric(invmat %*% vec) } # Y = M X + V ans <- mat %*% rbind(X$x, X$y) + matrix(vec, nrow=2L, ncol=length(X$x)) return(list(x = ans[1L,], y = ans[2L,])) } affinexypolygon <- function(p, mat=diag(c(1,1)), vec=c(0,0), detmat=det(mat)) { # transform (x,y) p[c("x","y")] <- affinexy(p, mat=mat, vec=vec) # transform area if(!is.null(p$area)) p$area <- p$area * detmat # if map has negative sign, cyclic order was reversed; correct it if(detmat < 0) p <- reverse.xypolygon(p, adjust=TRUE) return(p) } "affine" <- function(X, ...) { UseMethod("affine") } "affine.owin" <- function(X, mat=diag(c(1,1)), vec=c(0,0), ..., rescue=TRUE) { verifyclass(X, "owin") vec <- as2vector(vec) if(!is.matrix(mat) || any(dim(mat) != c(2,2))) stop(paste(sQuote("mat"), "should be a 2 x 2 matrix")) diagonalmatrix <- all(mat == diag(diag(mat))) scaletransform <- diagonalmatrix && (length(unique(diag(mat))) == 1) newunits <- if(scaletransform) unitname(X) else as.unitname(NULL) # switch(X$type, rectangle={ if(diagonalmatrix) { # result is a rectangle Y <- owinInternalRect(range(mat[1L,1L] * X$xrange + vec[1L]), range(mat[2L,2L] * X$yrange + vec[2L])) unitname(Y) <- newunits return(Y) } else { # convert rectangle to polygon P <- as.polygonal(X) # call polygonal case return(affine.owin(P, mat, vec, rescue=rescue)) } }, polygonal={ # Transform the polygonal boundaries bdry <- lapply(X$bdry, affinexypolygon, mat=mat, vec=vec, detmat=det(mat)) # Compile result W <- owin(poly=bdry, check=FALSE, unitname=newunits) # Result might be a rectangle: if so, convert to rectangle type if(rescue) W <- rescue.rectangle(W) return(W) }, mask={ #' binary mask if(sqrt(abs(det(mat))) < .Machine$double.eps) stop("Matrix of linear transformation is singular") newpixels <- (length(list(...)) > 0) && any(dim(X) != rev(spatstat.options("npixel"))) if(diagonalmatrix && !newpixels) { #' diagonal matrix: apply map to row and column locations m <- X$m d <- X$dim newbox <- affine(Frame(X), mat=mat, vec=vec) xscale <- diag(mat)[1L] yscale <- diag(mat)[2L] xcol <- xscale * X$xcol + vec[1L] yrow <- yscale * X$yrow + vec[2L] if(xscale < 0) { #' x scale is negative xcol <- rev(xcol) m <- m[, (d[2L]:1)] } if(yscale < 0) { ## y scale is negative yrow <- rev(yrow) m <- m[(d[1L]:1), ] } W <- owin(mask=m, xy=list(x=xcol, y=yrow), xrange=newbox$xrange, yrange=newbox$yrange, unitname=newunits) } else { #' general case #' create box containing transformed window newframe <- boundingbox(affinexy(corners(X), mat, vec)) if(newpixels) { W <- as.mask(newframe, ...) } else { #' determine pixel size mp <- mat %*% cbind(c(X$xstep, 0), c(0, X$ystep)) len <- sqrt(colSums(mp^2)) xcos <- abs(mp[1,1])/len[1] ycos <- abs(mp[1,2])/len[2] if(xcos > ycos) { newxstep <- len[1] newystep <- len[2] } else { newxstep <- len[2] newystep <- len[1] } W <- as.mask(newframe, eps=c(newxstep, newystep)) } pixelxy <- rasterxy.mask(W) xybefore <- affinexy(pixelxy, mat, vec, invert=TRUE) W$m[] <- with(xybefore, inside.owin(x, y, X)) W <- intersect.owin(W, boundingbox(W)) } if(rescue) W <- rescue.rectangle(W) return(W) }, stop("Unrecognised window type") ) } "affine.ppp" <- function(X, mat=diag(c(1,1)), vec=c(0,0), ...) { verifyclass(X, "ppp") vec <- as2vector(vec) r <- affinexy(X, mat, vec) w <- affine.owin(X$window, mat, vec, ...) return(ppp(r$x, r$y, window=w, marks=marks(X, dfok=TRUE), check=FALSE)) } "affine.im" <- function(X, mat=diag(c(1,1)), vec=c(0,0), ...) { verifyclass(X, "im") vec <- as2vector(vec) if(!is.matrix(mat) || any(dim(mat) != c(2,2))) stop(paste(sQuote("mat"), "should be a 2 x 2 matrix")) # Inspect the determinant detmat <- det(mat) if(sqrt(abs(detmat)) < .Machine$double.eps) stop("Matrix of linear transformation is singular") # diagonalmatrix <- all(mat == diag(diag(mat))) scaletransform <- diagonalmatrix && (length(unique(diag(mat))) == 1L) newunits <- if(scaletransform) unitname(X) else as.unitname(NULL) newpixels <- (length(list(...)) > 0) && any(dim(X) != rev(spatstat.options("npixel"))) # if(diagonalmatrix && !newpixels) { # diagonal matrix: apply map to row and column locations v <- X$v d <- X$dim newbox <- affine(as.rectangle(X), mat=mat, vec=vec) xscale <- diag(mat)[1L] yscale <- diag(mat)[2L] xcol <- xscale * X$xcol + vec[1L] yrow <- yscale * X$yrow + vec[2L] if(xscale < 0) { # x scale is negative xcol <- rev(xcol) v <- v[, (d[2L]:1)] } if(yscale < 0) { # y scale is negative yrow <- rev(yrow) v <- v[(d[1L]:1), ] } Y <- im(v, xcol=xcol, yrow=yrow, xrange=newbox$xrange, yrange=newbox$yrange, unitname=newunits) } else { # general case # create box containing transformed image newframe <- boundingbox(affinexy(corners(X), mat, vec)) if(newpixels) { W <- as.mask(newframe, ...) } else { #' determine pixel size mp <- mat %*% cbind(c(X$xstep, 0), c(0, X$ystep)) len <- sqrt(colSums(mp^2)) xcos <- abs(mp[1,1])/len[1] ycos <- abs(mp[1,2])/len[2] if(xcos > ycos) { newxstep <- len[1] newystep <- len[2] } else { newxstep <- len[2] newystep <- len[1] } W <- as.mask(newframe, eps=c(newxstep, newystep)) } unitname(W) <- newunits # raster for transformed image naval <- switch(X$type, factor= , integer = NA_integer_, logical = as.logical(NA_integer_), real = NA_real_, complex = NA_complex_, character = NA_character_, NA) Y <- as.im(W, value=naval) # preimages of pixels of transformed image xx <- as.vector(rasterx.im(Y)) yy <- as.vector(rastery.im(Y)) pre <- affinexy(list(x=xx, y=yy), mat, vec, invert=TRUE) # sample original image if(X$type != "factor") { Y$v[] <- lookup.im(X, pre$x, pre$y, naok=TRUE) } else { lab <- levels(X) lev <- seq_along(lab) Y$v[] <- lookup.im(eval.im(as.integer(X)), pre$x, pre$y, naok=TRUE) Y <- eval.im(factor(Y, levels=lev, labels=lab)) } } return(Y) } ### ---------------------- reflect ---------------------------------- reflect <- function(X) { UseMethod("reflect") } reflect.default <- function(X) { affine(X, mat=diag(c(-1,-1))) } reflect.im <- function(X) { stopifnot(is.im(X)) out <- with(X, list(v = v[dim[1L]:1, dim[2L]:1], dim = dim, xrange = rev(-xrange), yrange = rev(-yrange), xstep = xstep, ystep = ystep, xcol = rev(-xcol), yrow = rev(-yrow), type = type, units = units)) class(out) <- "im" return(out) } ### ---------------------- shift ---------------------------------- "shift" <- function(X, ...) { UseMethod("shift") } shiftxy <- function(X, vec=c(0,0)) { vec <- as.numeric(vec) n <- length(vec) if(n == 0) { warning("Null displacement vector; treated as zero") return(X) } else if(n != 2) { stop(paste("Displacement vector has length", n, "!= 2"), call.=FALSE) } list(x = X$x + vec[1L], y = X$y + vec[2L]) } shiftxypolygon <- function(p, vec=c(0,0)) { # transform (x,y), retaining other data p[c("x","y")] <- shiftxy(p, vec=vec) return(p) } shift.owin <- function(X, vec=c(0,0), ..., origin=NULL) { verifyclass(X, "owin") if(!is.null(origin)) { if(!missing(vec)) warning("argument vec ignored; argument origin has precedence") locn <- interpretAsOrigin(origin, X) vec <- -locn } vec <- as2vector(vec) # Shift the bounding box X$xrange <- X$xrange + vec[1L] X$yrange <- X$yrange + vec[2L] switch(X$type, rectangle={ }, polygonal={ # Shift the polygonal boundaries X$bdry <- lapply(X$bdry, shiftxypolygon, vec=vec) }, mask={ # Shift the pixel coordinates X$xcol <- X$xcol + vec[1L] X$yrow <- X$yrow + vec[2L] # That's all --- the mask entries are unchanged }, stop("Unrecognised window type") ) # tack on shift vector attr(X, "lastshift") <- vec # units are unchanged return(X) } shift.ppp <- function(X, vec=c(0,0), ..., origin=NULL) { verifyclass(X, "ppp") if(!is.null(origin)) { if(!missing(vec)) warning("argument vec ignored; argument origin has precedence") locn <- interpretAsOrigin(origin, Window(X)) vec <- -locn } vec <- as2vector(vec) # perform shift r <- shiftxy(X, vec) w <- shift.owin(X$window, vec) Y <- ppp(r$x, r$y, window=w, marks=marks(X, dfok=TRUE), check=FALSE) # tack on shift vector attr(Y, "lastshift") <- vec return(Y) } getlastshift <- function(X) { v <- attr(X, "lastshift") if(is.null(v)) stop(paste("Internal error: shifted object of class", sQuote(as.character(class(X))[1L]), "does not have \"lastshift\" attribute"), call.=FALSE) if(!(is.numeric(v) && length(v) == 2L)) stop("Internal error: \"lastshift\" attribute is not a vector", call.=FALSE) return(v) } putlastshift <- function(X, vec) { attr(X, "lastshift") <- vec return(X) } interpretAsOrigin <- function(x, W) { if(is.character(x)) { x <- paste(x, collapse="") x <- match.arg(x, c("centroid", "midpoint", "left", "right", "top", "bottom", "bottomleft", "bottomright", "topleft", "topright")) W <- as.owin(W) xr <- W$xrange yr <- W$yrange x <- switch(x, centroid = { unlist(centroid.owin(W)) }, midpoint = { c(mean(xr), mean(yr)) }, left = { c(xr[1L], mean(yr)) }, right = { c(xr[2L], mean(yr)) }, top = { c(mean(xr), yr[2L]) }, bottom = { c(mean(xr), yr[1L]) }, bottomleft = { c(xr[1L], yr[1L]) }, bottomright = { c(xr[2L], yr[1L]) }, topleft = { c(xr[1L], yr[2L]) }, topright = { c(xr[2L], yr[2L]) }, stop(paste("Unrecognised option",sQuote(x)), call.=FALSE)) } return(as2vector(x)) } ### ---------------------- scalar dilation --------------------------------- scalardilate <- function(X, f, ...) { UseMethod("scalardilate") } scalardilate.default <- function(X, f, ...) { trap.extra.arguments(..., .Context="In scalardilate(X,f)") check.1.real(f, "In scalardilate(X,f)") stopifnot(is.finite(f) && f > 0) Y <- affine(X, mat=diag(c(f,f))) return(Y) } scalardilate.breakpts <- function(X, f, ...) { out <- with(X, list(val = f*val, max = f*max, ncells = ncells, r = f*r, even = even, npos = npos, step = if(is.null(step)) NULL else (f*step))) class(out) <- "breakpts" out } scalardilate.im <- scalardilate.owin <- scalardilate.psp <- scalardilate.ppp <- function(X, f, ..., origin=NULL) { trap.extra.arguments(..., .Context="In scalardilate(X,f)") check.1.real(f, "In scalardilate(X,f)") stopifnot(is.finite(f) && f > 0) if(!is.null(origin)) { X <- shift(X, origin=origin) negorig <- getlastshift(X) } else negorig <- c(0,0) Y <- affine(X, mat=diag(c(f, f)), vec = -negorig) return(Y) } spatstat.geom/R/clickpoly.R0000644000176200001440000000422414611065351015364 0ustar liggesusers# # clickpoly.R # # # $Revision: 1.12 $ $Date: 2024/02/04 08:04:51 $ # # clickpoly <- function(add=FALSE, nv=NULL, np=1, ...) { if((!add) | dev.cur() == 1L) { plot(0,0,type="n", xlab="", ylab="", xlim=c(0,1), ylim=c(0,1), asp=1.0, axes=FALSE) rect(0,0,1,1) } spatstatLocator(0) ## check locator is enabled gon <- list() stopifnot(np >= 1) # for(i in 1:np) { if(np > 1) cat(paste(".... Polygon number", i, ".....\n")) if(!is.null(nv)) cat(paste("click", nv, "times in window\n")) else cat(paste("to add points: click left mouse button in window\n", " to exit: press ESC or click middle mouse button\n", "[The last point should NOT repeat the first point]\n")) xy <- do.call(spatstatLocator, resolve.defaults(if(!is.null(nv)) list(n=nv) else list(), list(...), list(type="o"))) if(Area.xypolygon(xy) < 0) xy <- lapply(xy, rev) gon[[i]] <- xy plotPolygonBdry(owin(poly=xy), ...) } result <- owin(poly=gon) plotPolygonBdry(result, ...) return(result) } clickbox <- function(add=TRUE, ...) { spatstatLocator(0) # check locator enabled cat("Click two corners of a box\n") if(!add) plot(owinInternalRect(), main="Click two corners of a box") a <- try(spatstatLocator(1), silent=TRUE) if(inherits(a, "try-error")) { ## add=TRUE but there is no current plot plot.new() a <- spatstatLocator(1, ...) } abline(v=a$x) abline(h=a$y) b <- spatstatLocator(1, ...) abline(v=b$x) abline(h=b$y) ab <- concatxy(a, b) result <- owinInternalRect(range(ab$x), range(ab$y)) plotPolygonBdry(result, ...) return(result) } plotPolygonBdry <- function(x, ...) { # filter appropriate arguments argh <- list(...) polyPars <- union(graphicsPars("lines"), graphicsPars("owin")) polyargs <- argh[names(argh) %in% polyPars] # change 'col' to 'border' nama <- names(polyargs) if(any(nama == "col") && !any(nama == "border")) names(polyargs)[nama == "col"] <- "border" # plot do.call(plot.owin, append(list(x=x, add=TRUE), polyargs)) } spatstat.geom/R/distances.R0000644000176200001440000001626614611065351015361 0ustar liggesusers# # distances.R # # $Revision: 1.50 $ $Date: 2022/05/21 09:52:11 $ # # # Interpoint distances between pairs # # pairdist <- function(X, ...) { UseMethod("pairdist") } pairdist.ppp <- function(X, ..., periodic=FALSE, method="C", squared=FALSE, metric=NULL) { verifyclass(X, "ppp") if(!is.null(metric)) { d <- invoke.metric(metric, "pairdist.ppp", X, ..., periodic=periodic, method=method, squared=squared) return(d) } if(!periodic) return(pairdist.default(X$x, X$y, method=method, squared=squared)) # periodic case W <- X$window if(W$type != "rectangle") stop(paste("periodic edge correction can't be applied", "in a non-rectangular window")) wide <- diff(W$xrange) high <- diff(W$yrange) return(pairdist.default(X$x, X$y, period=c(wide,high), method=method, squared=squared)) } pairdist.default <- function(X, Y=NULL, ..., period=NULL, method="C", squared=FALSE) { warn.no.metric.support("pairdist.default", ...) if(!is.null(dim(X)) && ncol(X) > 2) stop("Data contain more than 2 coordinates") xy <- xy.coords(X,Y)[c("x","y")] if(identical(xy$xlab, "Index")) stop("Cannot interpret data as 2-dimensional coordinates") x <- xy$x y <- xy$y n <- length(x) if(length(y) != n) stop("lengths of x and y do not match") # special cases if(n == 0) return(matrix(numeric(0), nrow=0, ncol=0)) else if(n == 1L) return(matrix(0,nrow=1L,ncol=1L)) if((periodic<- !is.null(period))) { stopifnot(is.numeric(period)) stopifnot(length(period) == 2 || length(period) == 1) stopifnot(all(period > 0)) if(length(period) == 1) period <- rep.int(period, 2) wide <- period[1L] high <- period[2L] } switch(method, interpreted={ xx <- matrix(rep.int(x, n), nrow = n) yy <- matrix(rep.int(y, n), nrow = n) if(!periodic) { d2 <- (xx - t(xx))^2 + (yy - t(yy))^2 } else { dx <- xx - t(xx) dy <- yy - t(yy) dx2 <- pmin.int(dx^2, (dx + wide)^2, (dx - wide)^2) dy2 <- pmin.int(dy^2, (dy + high)^2, (dy - high)^2) d2 <- dx2 + dy2 } if(squared) dout <- d2 else dout <- sqrt(d2) }, C={ d <- numeric( n * n) if(!periodic) { z<- .C(SG_Cpairdist, n = as.integer(n), x= as.double(x), y= as.double(y), squared=as.integer(squared), d= as.double(d), PACKAGE="spatstat.geom") } else { z <- .C(SG_CpairPdist, n = as.integer(n), x= as.double(x), y= as.double(y), xwidth=as.double(wide), yheight=as.double(high), squared = as.integer(squared), d= as.double(d), PACKAGE="spatstat.geom") } dout <- matrix(z$d, nrow=n, ncol=n) }, stop(paste("Unrecognised method", sQuote(method))) ) return(dout) } crossdist <- function(X, Y, ...) { UseMethod("crossdist") } crossdist.ppp <- function(X, Y, ..., periodic=FALSE, method="C", squared=FALSE, metric=NULL) { verifyclass(X, "ppp") Y <- as.ppp(Y) if(!is.null(metric)) { d <- invoke.metric(metric, "crossdist.ppp", X, Y, ..., periodic=periodic, method=method, squared=squared) return(d) } if(!periodic) return(crossdist.default(X$x, X$y, Y$x, Y$y, method=method, squared=squared)) # periodic case WX <- X$window WY <- Y$window if(WX$type != "rectangle" || WY$type != "rectangle") stop(paste("periodic edge correction can't be applied", "in non-rectangular windows")) if(!is.subset.owin(WX,WY) || !is.subset.owin(WY, WX)) stop(paste("periodic edge correction is not implemented", "for the case when X and Y lie in different rectangles")) wide <- diff(WX$xrange) high <- diff(WX$yrange) return(crossdist.default(X$x, X$y, Y$x, Y$y, period=c(wide,high), method=method, squared=squared)) } crossdist.default <- function(X, Y, x2, y2, ..., period=NULL, method="C", squared=FALSE) { x1 <- X y1 <- Y # returns matrix[i,j] = distance from (x1[i],y1[i]) to (x2[j],y2[j]) if(length(x1) != length(y1)) stop("lengths of x and y do not match") if(length(x2) != length(y2)) stop("lengths of x2 and y2 do not match") n1 <- length(x1) n2 <- length(x2) if(n1 == 0 || n2 == 0) return(matrix(numeric(0), nrow=n1, ncol=n2)) if((periodic<- !is.null(period))) { stopifnot(is.numeric(period)) stopifnot(length(period) == 2 || length(period) == 1) stopifnot(all(period > 0)) if(length(period) == 1L) period <- rep.int(period, 2) wide <- period[1L] high <- period[2L] } switch(method, interpreted = { X1 <- matrix(rep.int(x1, n2), ncol = n2) Y1 <- matrix(rep.int(y1, n2), ncol = n2) X2 <- matrix(rep.int(x2, n1), ncol = n1) Y2 <- matrix(rep.int(y2, n1), ncol = n1) if(!periodic) d2 <- (X1 - t(X2))^2 + (Y1 - t(Y2))^2 else { dx <- X1 - t(X2) dy <- Y1 - t(Y2) dx2 <- pmin.int(dx^2, (dx + wide)^2, (dx - wide)^2) dy2 <- pmin.int(dy^2, (dy + high)^2, (dy - high)^2) d2 <- dx2 + dy2 } return(if(squared) d2 else sqrt(d2)) }, C = { if(!periodic) { z<- .C(SG_Ccrossdist, nfrom = as.integer(n1), xfrom = as.double(x1), yfrom = as.double(y1), nto = as.integer(n2), xto = as.double(x2), yto = as.double(y2), squared = as.integer(squared), d = as.double(matrix(0, nrow=n1, ncol=n2)), PACKAGE="spatstat.geom") } else { z<- .C(SG_CcrossPdist, nfrom = as.integer(n1), xfrom = as.double(x1), yfrom = as.double(y1), nto = as.integer(n2), xto = as.double(x2), yto = as.double(y2), xwidth = as.double(wide), yheight = as.double(high), squared = as.integer(squared), d = as.double(matrix(0, nrow=n1, ncol=n2)), PACKAGE="spatstat.geom") } return(matrix(z$d, nrow=n1, ncol=n2)) }, stop(paste("Unrecognised method", method)) ) } spatstat.geom/R/persp.im.R0000644000176200001440000002653614723232636015150 0ustar liggesusers## ## persp.im.R ## ## 'persp' method for image objects ## plus annotation ## ## $Revision: 1.29 $ $Date: 2023/02/28 01:53:02 $ ## persp.im <- function(x, ..., colmap=NULL, colin=x, apron=FALSE, visible=FALSE) { xname <- short.deparse(substitute(x)) xinfo <- summary(x) if(xinfo$type == "factor") stop("Perspective plot is inappropriate for factor-valued image") ## check whether 'col' was specified when 'colmap' was intended Col <- list(...)$col if(is.null(colmap) && !is.null(Col) && !is.matrix(Col) && length(Col) != 1) warning("Argument col is not a matrix. Did you mean colmap?") if(!missing(colin)) { ## separate image to determine colours verifyclass(colin, "im") if(!compatible(colin, x)) { ## resample 'colin' onto grid of 'x' colin <- as.im(colin, W=x) } if(is.null(colmap)) colmap <- spatstat.options("image.colfun")(128) } pop <- spatstat.options("par.persp") ## if(is.function(colmap) && !inherits(colmap, "colourmap")) { ## coerce to a 'colourmap' if possible clim <- range(colin, finite=TRUE) if(names(formals(colmap))[1] == "n") { colval <- colmap(128) colmap <- colourmap(colval, range=clim) } else { ## colour map determined by a rule (e.g. 'beachcolours') colmap <- invokeColourmapRule(colmap, colin, zlim=clim, colargs=list(...)) if(is.null(colmap)) stop("Unrecognised syntax for colour function") } } ## colour map? if(is.null(colmap)) { colinfo <- list(col=NULL) } else if(inherits(colmap, "colourmap")) { ## colour map object ## apply colour function to image data colval <- eval.im(colmap(colin)) colval <- t(as.matrix(colval)) ## strip one row and column for input to persp.default colval <- colval[-1, -1] ## replace NA by arbitrary value isna <- is.na(colval) if(any(isna)) { stuff <- attr(colmap, "stuff") colvalues <- stuff$outputs colval[isna] <- colvalues[1] } ## pass colour matrix (and suppress lines) colinfo <- list(col=colval, border=NA) } else { ## interpret 'colmap' as colour map if(is.list(colmap) && all(c("breaks", "col") %in% names(colmap))) { breaks <- colmap$breaks colvalues <- colmap$col } else if(is.vector(colmap)) { colvalues <- colmap breaks <- quantile(colin, seq(from=0,to=1,length.out=length(colvalues)+1)) if(!all(ok <- !duplicated(breaks))) { breaks <- breaks[ok] colvalues <- colvalues[ok[-1]] } } else warning("Unrecognised format for colour map") ## apply colour map to image values colid <- cut.im(colin, breaks=breaks, include.lowest=TRUE) colval <- eval.im(colvalues[unclass(colid)]) colval <- t(as.matrix(colval)) ## strip one row and column for input to persp.default colval <- colval[-1, -1] colval[is.na(colval)] <- colvalues[1] ## pass colour matrix (and suppress lines) colinfo <- list(col=colval, border=NA) } if(apron) { ## add an 'apron' zlim <- list(...)$zlim bottom <- if(!is.null(zlim)) zlim[1] else min(x) x <- na.handle.im(x, na.replace=bottom) x <- padimage(x, bottom) xinfo <- summary(x) if(is.matrix(colval <- colinfo$col)) { colval <- matrix(col2hex(colval), nrow(colval), ncol(colval)) grijs <- col2hex("lightgrey") colval <- cbind(grijs, rbind(grijs, colval, grijs), grijs) colinfo$col <- colval } } if(spatstat.options("monochrome")) colinfo$col <- to.grey(colinfo$col) ## get reasonable z scale while fixing x:y aspect ratio if(xinfo$type %in% c("integer", "real")) { zrange <- xinfo$range if(diff(zrange) > 0) { xbox <- as.rectangle(x) zscale <- 0.5 * mean(diff(xbox$xrange), diff(xbox$yrange))/diff(zrange) zlim <- zrange } else { zscale <- NULL mx <- xinfo$mean zlim <- mx + c(-1,1) * if(mx == 0) 0.1 else min(abs(mx), 1) } } else zscale <- zlim <- NULL dotargs <- list(...) if(spatstat.options("monochrome")) dotargs <- col.args.to.grey(dotargs) ## catch argument 'adj.main' and convert to recognised argument 'adj' if(!is.na(k <- match("adj.main", names(dotargs)))) names(dotargs)[k] <- "adj" xcol <- x$xcol yrow <- x$yrow zmat <- t(x$v) dont.complain.about(xcol, yrow, zmat) yargh <- resolve.defaults(list(x=quote(xcol), y=quote(yrow), z=quote(zmat)), dotargs, pop, colinfo, list(xlab="x", ylab="y", zlab=xname), list(scale=FALSE, expand=zscale, zlim=zlim), list(main=xname), .StripNull=TRUE) jawab <- do.call.matched(persp, yargh, funargs=graphicsPars("persp")) attr(jawab, "expand") <- yargh$expand if(visible) attr(jawab, "visible") <- perspVisible(x=x, M=jawab) return(invisible(jawab)) } perspVisible <- function(x, y, z, M) { if(!is.matrix(M)) stop("M should be a matrix") if(!all(dim(M) == c(4,4))) stop("M should be a 4x4 matrix") ## handle all options available in persp.default xgiven <- !missing(x) ygiven <- !missing(y) zgiven <- !missing(z) if(xgiven && ygiven && zgiven) { xmargin <- x ymargin <- y values <- z } else if(xgiven && !ygiven && !zgiven) { values <- x xmargin <- ymargin <- NULL } else if(!xgiven && !ygiven && zgiven) { values <- z xmargin <- ymargin <- NULL } else stop("x or z must be given") ## extract data as matrix 'Xmat' and data frame 'xyz' if(is.im(values)) { ## spatstat image convention x = col, y = row X <- values Xmat <- as.matrix(X) xyz <- as.matrix(as.data.frame(X)) # drops NA entries xstep <- X$xstep ystep <- X$ystep } else if(is.matrix(x)) { ## base graphics image convention x = row, y = col ## convert to spatstat convention Xmat <- t(values) if(is.null(xmargin)) xmargin <- seq(0, 1, length.out=ncol(Xmat)) if(is.null(ymargin)) ymargin <- seq(0, 1, length.out=nrow(Xmat)) xyz <- cbind(x=xmargin[col(Xmat)], y=ymargin[row(Xmat)], z=as.numeric(Xmat)) xyz <- xyz[complete.cases(xyz), ,drop=FALSE] xstep <- mean(diff(xmargin)) ystep <- mean(diff(ymargin)) } else stop("format is not understood") ## project the coordinates ## onto (x,y) plane of plot and z axis pointing out of it v <- cbind(xyz, 1) %*% M px <- v[,1]/v[,4] py <- v[,2]/v[,4] pz <- v[,3]/v[,4] pw <- v[,4] ## determine greatest possible difference in 'depth' in one pixel step PZ <- Xmat ok <- !is.na(PZ) PZ[ok] <- pz maxslipx <- max(0, abs(apply(PZ, 1, diff)), na.rm=TRUE) maxslipy <- max(0, abs(apply(PZ, 2, diff)), na.rm=TRUE) ## First, determine which pixels are in front d <- ceiling(dim(Xmat)/2) jx <- cut(px, breaks=d[2]) iy <- cut(py, breaks=d[1]) zmax <- tapply(pz, list(iy,jx), max) infront <- (pz > zmax[cbind(iy,jx)] - maxslipx - maxslipy) ## Second, determine whether outward normal to surface is pointing to viewer dzdx <- cbind(0, t(apply(Xmat, 1, diff)))/xstep dzdy <- rbind(0, apply(Xmat, 2, diff))/ystep dzdx <- as.vector(dzdx[ok]) dzdy <- as.vector(dzdy[ok]) ## unscaled normal vector normalx <- -dzdx normaly <- -dzdy normalz <- 1 ## derivative of projected depth with respect to 3D input position dDdx <- (M[1,3] - M[1,4]/pz)/pw dDdy <- (M[2,3] - M[2,4]/pz)/pw dDdz <- (M[3,3] - M[3,4]/pz)/pw ## inner product = derivative of projected depth along outward normal vector dotprod <- normalx * dDdx + normaly * dDdy + normalz * dDdz ## Visible? isvis <- infront & (dotprod < 0) if(!anyNA(Xmat)) { answer <- isvis } else { answer <- !is.na(as.vector(Xmat)) answer[answer] <- isvis } Vmat <- matrix(answer, nrow(Xmat), ncol(Xmat)) if(!is.im(values)) return(t(Vmat)) V <- (X > 0) V[drop=FALSE] <- Vmat return(V) } perspPoints <- function(x, y=NULL, ..., Z, M, occluded=TRUE) { xy <- xy.coords(x, y) stopifnot(is.im(Z)) X <- as.ppp(xy, W=Frame(Z)) if(!(is.matrix(M) && all(dim(M) == 4))) stop("M should be a 4 x 4 matrix, returned from persp()") if(occluded) { V <- attr(M, "visible") if(is.null(V)) { warning(paste("M does not contain visibility information;", "it should be recomputed by persp() with visible=TRUE")) } else { ## restrict to visible points VX <- V[X, drop=FALSE] VX[is.na(VX)] <- FALSE X <- X[VX] } } #' determine heights ZX <- Z[X, drop=FALSE] # may contain NA #' transform and plot points(trans3d(X$x, X$y, ZX, M), ...) } perspSegments <- local({ perspSegments <- function(x0, y0=NULL, x1=NULL, y1=NULL, ..., Z, M, occluded=TRUE) { stopifnot(is.im(Z)) if(!(is.matrix(M) && all(dim(M) == 4))) stop("M should be a 4 x 4 matrix, returned from persp()") if(occluded) { V <- attr(M, "visible") if(is.null(V)) warning(paste("M does not contain visibility information;", "it should be recomputed by persp() with visible=TRUE")) } if(is.psp(X <- x0) && is.null(y0) && is.null(x1) && is.null(y1)) { eX <- X$ends # nX <- nrow(eX) } else { # nX <- length(x0) check.nvector(x0, naok=TRUE, vname="x0") check.nvector(y0, naok=TRUE, vname="y0") check.nvector(x1, naok=TRUE, vname="x1") check.nvector(y1, naok=TRUE, vname="y1") eX <- cbind(x0, y0, x1, y1) } if(!occluded || is.null(V)) { ## no segments will be occluded Y <- eX } else { ## chop each segment to length of single pixel along either axis xstep <- Z$xstep ystep <- Z$ystep Y <- do.call(rbind, lapply(as.data.frame(t(eX)), chopsegment, eps1=xstep, eps2=ystep)) ## determine which segments are visible yleft <- list(x=Y[,1], y=Y[,2]) yright <- list(x=Y[,3], y=Y[,4]) ok <- V[yleft, drop=FALSE] & V[yright, drop=FALSE] ok[is.na(ok)] <- FALSE Y <- Y[ok, ,drop=FALSE] } if(nrow(Y) == 0) return(invisible(NULL)) ## map to projected plane x0y0 <- trans3d(Y[,1], Y[,2], Z[list(x=Y[,1],y=Y[,2]), drop=FALSE], M) x1y1 <- trans3d(Y[,3], Y[,4], Z[list(x=Y[,3],y=Y[,4]), drop=FALSE], M) segments(x0y0$x, x0y0$y, x1y1$x, x1y1$y, ...) } chopsegment <- function(x, eps1, eps2) { n1 <- ceiling(abs(x[3] - x[1])/eps1) n2 <- ceiling(abs(x[4] - x[2])/eps2) n <- max(1, n1, n2) b <- (1:n)/n a <- (0:(n-1))/n return(cbind(x[1] + a * (x[3]-x[1]), x[2] + a * (x[4]-x[2]), x[1] + b * (x[3]-x[1]), x[2] + b * (x[4]-x[2]))) } perspSegments }) perspLines <- function(x, y=NULL, ..., Z, M, occluded=TRUE) { xy <- xy.coords(x, y) n <- length(xy$x) perspSegments(x[-n], y[-n], x[-1], y[-1], Z=Z, M=M, ..., occluded=occluded) } perspContour <- function(Z, M, ..., nlevels=10, levels=pretty(range(Z), nlevels), occluded=TRUE) { cl <- contourLines(x=Z$xcol, y=Z$yrow, z=t(Z$v), nlevels=nlevels, levels=levels) for(i in seq_along(cl)) { cli <- cl[[i]] perspLines(cli$x, cli$y, ..., Z=Z, M=M, occluded=occluded) } invisible(NULL) } spatstat.geom/R/options.R0000644000176200001440000006016514716550725015106 0ustar liggesusers# # options.R # # Spatstat options and other internal states # # $Revision: 1.96 $ $Date: 2024/11/18 02:44:24 $ # # putSpatstatVariable("Spatstat.Options", list()) putSpatstatVariable("Spatstat.ProgressBar", NULL) putSpatstatVariable("Spatstat.ProgressData", NULL) putSpatstatVariable("warnedkeys", character(0)) ## Kovesi's uniform colour map, row 29, linear 'bmy' .Kovesi29 <- c( "#000C7D", "#000D7E", "#000D80", "#000E81", "#000E83", "#000E85", "#000F86", "#000F88", "#00108A", "#00108B", "#00118D", "#00118F", "#001190", "#001292", "#001293", "#001295", "#001396", "#001398", "#001399", "#00149A", "#00149C", "#00149D", "#00149E", "#00159F", "#0015A0", "#0015A1", "#0015A2", "#0015A3", "#0015A4", "#0016A5", "#0016A6", "#0016A6", "#0016A7", "#0016A8", "#0016A8", "#0016A8", "#0A16A9", "#1516A9", "#1D15A9", "#2315A9", "#2915A9", "#2F15A8", "#3414A8", "#3914A7", "#3E13A6", "#4313A5", "#4712A4", "#4C12A3", "#5011A2", "#5311A1", "#5710A0", "#5A0F9F", "#5E0F9E", "#610E9E", "#640E9D", "#670D9C", "#6A0D9B", "#6C0C9A", "#6F0B99", "#720B98", "#740A98", "#770A97", "#790996", "#7C0896", "#7E0895", "#800794", "#810794", "#840693", "#860692", "#880692", "#8A0591", "#8C0591", "#8E0490", "#900490", "#92048F", "#94038F", "#96038E", "#98038E", "#9A028D", "#9C028D", "#9E028D", "#A0018C", "#A2018C", "#A4018B", "#A6018B", "#A8008A", "#AA008A", "#AB0089", "#AD0089", "#AF0088", "#B10088", "#B30087", "#B50087", "#B70086", "#B80086", "#BA0086", "#BC0085", "#BE0085", "#C00084", "#C20084", "#C30083", "#C50083", "#C70082", "#C90082", "#CB0081", "#CD0081", "#CE0080", "#D00080", "#D20080", "#D40080", "#D5007F", "#D7007F", "#D9007E", "#DA007E", "#DC007D", "#DD007C", "#DF017C", "#E1027B", "#E2047B", "#E4067A", "#E5087A", "#E70B79", "#E80D78", "#E91078", "#EB1277", "#EC1477", "#ED1676", "#EF1875", "#F01A75", "#F11C74", "#F31E73", "#F42073", "#F52272", "#F62471", "#F72671", "#F82870", "#FA2A6F", "#FB2C6F", "#FC2E6E", "#FD306D", "#FE326C", "#FE346C", "#FE366B", "#FE386A", "#FE3A6A", "#FE3D69", "#FE3F68", "#FE4167", "#FE4366", "#FE4566", "#FE4765", "#FE4964", "#FE4B63", "#FE4D62", "#FE5062", "#FE5261", "#FE5460", "#FE565F", "#FE585E", "#FE5A5D", "#FE5D5C", "#FE5F5B", "#FE615B", "#FE635A", "#FE6559", "#FE6758", "#FE6A57", "#FE6C56", "#FE6E55", "#FE7054", "#FE7253", "#FE7452", "#FE7651", "#FE7850", "#FE7A4E", "#FE7C4D", "#FE7E4C", "#FE7F4B", "#FE804A", "#FE8249", "#FE8448", "#FE8647", "#FE8745", "#FE8944", "#FE8B43", "#FE8D42", "#FE8E40", "#FE903F", "#FE923E", "#FE943C", "#FE953B", "#FE9739", "#FE9938", "#FE9A36", "#FE9C35", "#FE9E33", "#FE9F32", "#FEA130", "#FEA22F", "#FEA42E", "#FEA52C", "#FEA72B", "#FEA82A", "#FEAA29", "#FEAB28", "#FEAD27", "#FEAE26", "#FEB026", "#FEB125", "#FEB324", "#FEB423", "#FEB523", "#FEB722", "#FEB822", "#FEBA21", "#FEBB20", "#FEBC20", "#FEBE1F", "#FEBF1F", "#FEC11F", "#FEC21E", "#FEC31E", "#FEC51E", "#FEC61D", "#FEC71D", "#FEC91D", "#FECA1D", "#FECB1D", "#FECD1D", "#FECE1C", "#FECF1C", "#FED11C", "#FED21C", "#FED31C", "#FED51C", "#FED61D", "#FED71D", "#FED91D", "#FEDA1D", "#FEDB1D", "#FEDD1D", "#FEDE1E", "#FEDF1E", "#FEE11E", "#FEE21E", "#FEE31F", "#FEE51F", "#FEE61F", "#FEE720", "#FEE820", "#FEEA21", "#FEEB21", "#FEEC22", "#FEEE22", "#FEEF23", "#FEF023") putSpatstatVariable("DefaultImageColours", .Kovesi29) .Spatstat.Default.Image.Colfun <- function(n) { z <- getSpatstatVariable("DefaultImageColours") interp.colours(z, n) } default.image.colours <- function() { getSpatstatVariable("DefaultImageColours") } reset.default.image.colours <- function(col=NULL) { if(is.null(col)) { col <- .Kovesi29 } else if(!is.colour(col)) { stop("col should be a vector of colour values") } putSpatstatVariable("DefaultImageColours", col) spatstat.options(image.colfun = .Spatstat.Default.Image.Colfun) return(invisible(col)) } warn.once <- function(key, ...) { warned <- getSpatstatVariable("warnedkeys") if(!(key %in% warned)) { warning(paste(...), call.=FALSE) putSpatstatVariable("warnedkeys", c(warned, key)) } return(invisible(NULL)) } ".Spat.Stat.Opt.Table" <- list( areainter.polygonal = list( ## use polygonal calculations in AreaInter default=FALSE, check=function(x) { is.logical(x) && length(x) == 1}, valid="a single logical value" ), checkpolygons = list( ## superseded superseded=TRUE, default=FALSE, check=function(x) { warning("spatstat.options('checkpolygons') will be ignored in future versions of spatstat", call.=FALSE) return(is.logical(x) && length(x) == 1) }, valid="a single logical value" ), checksegments = list( ## default value of 'check' for psp objects default=TRUE, check=function(x) { is.logical(x) && length(x) == 1}, valid="a single logical value" ), closepairs.newcode=list( ## use new code for 'closepairs' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), closepairs.altcode=list( ## use alternative code for 'closepairs' default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), crossing.psp.useCall=list( ## use new code for 'crossing.psp' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), crosspairs.newcode=list( ## use new code for 'crosspairs' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), densityTransform=list( ## use experimental new C routines for 'density.ppp' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), densityC=list( ## use C routines for 'density.ppp' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), dpp.maxmatrix=list( ## maximum size of matrix in dppeigen default=2^24, # 16,777,216 check=function(x) { is.numeric(x) && length(x) == 1 && all(x == ceiling(x)) && all(x > 1024) }, valid="a single integer, greater than 1024" ), exactdt.checks.data=list( ## whether 'exactdt' checks validity of return value default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), expand=list( ## default area expansion factor default=2, check=function(x) { is.numeric(x) && length(x) == 1 && all(x > 1) }, valid="a single numeric value, greater than 1" ), expand.polynom=list( ## whether to expand polynom() in ppm formulae default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), fasteval=list( ## whether to use 'fasteval' code if available default="on", check=function(x) { x %in% c("off", "on", "test") }, valid="one of the strings \'off\', \'on\' or \'test\'" ), fastpois=list( # whether to use fast algorithm for rpoispp() when lambda is an image default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), fastthin=list( # whether to use fast C algorithm for rthin() when P is constant default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), fastK.lgcp=list( ## whether to cut a few corners in 'lgcp.estK' default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), fast.trigraph=list( ## whether to use C function triograph or trigraph in edges2triangles default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), fixpolygons = list( ## whether to repair polygons automatically default=TRUE, check=function(x) { is.logical(x) && length(x) == 1}, valid="a single logical value" ), gpclib=list( ## defunct! superseded=TRUE, default=FALSE, check=function(x) { message("gpclib is no longer needed") return(TRUE) }, valid="a single logical value" ), huge.npoints=list( ## threshold to trigger a warning from rpoispp default=1e6, check=function(x) { is.numeric(x) && length(x) == 1 && all(x == ceiling(x)) && all(x > 1024) }, valid="a single integer, greater than 1024" ), image.colfun=list( ## default colour scheme for plot.im # default=function(n){topo.colors(n)}, default=.Spatstat.Default.Image.Colfun, check=function(x) { if(!is.function(x) || length(formals(x)) == 0) return(FALSE) y <- x(42) if(length(y) != 42 || !is.character(y)) return(FALSE) z <- try(col2rgb(y), silent=TRUE) return(!inherits(z, "try-error")) }, valid="a function f(n) that returns character strings, interpretable as colours" ), Kcom.remove.zeroes=list( ## whether Kcom removes zero distances default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), maxedgewt=list( ## maximum edge correction weight default=100, check=function(x){ is.numeric(x) && length(x) == 1 && is.finite(x) && all(x >= 1) }, valid="a finite numeric value, not less than 1" ), maxmatrix=list( ## maximum size of matrix of pairs of points in mpl.R default=2^24, # 16,777,216 check=function(x) { is.numeric(x) && length(x) == 1 && all(x == ceiling(x)) && all(x > 1024) }, valid="a single integer, greater than 1024" ), mincon.trace = list( ## tracing debugger in mincontrast default=FALSE, check=function(x) { is.logical(x) && length(x) == 1}, valid="a single logical value" ), monochrome = list( ## switch for monochrome colour scheme default=FALSE, check=function(x) { is.logical(x) && length(x) == 1}, valid="a single logical value" ), n.bandwidth=list( ## number of values of bandwidth to try in bandwidth selection default=32, check=function(x) { is.numeric(x) && (length(x) == 1) && all(x == ceiling(x)) && all(x > 2) }, valid="a single integer, greater than 2" ), ndummy.min=list( ## minimum grid size for dummy points default=32, check=function(x) { is.numeric(x) && length(x) <= 2 && all(x == ceiling(x)) && all(x > 1) }, valid="a single integer or a pair of integers, greater than 1" ), ngrid.disc=list( ## number of grid points used to calculate area in area-interaction default=128, check=function(x) { is.numeric(x) && length(x) == 1 && all(x == ceiling(x)) && all(x > 1) }, valid="a single integer, greater than 1" ), npixel=list( ## default pixel dimensions default=128, check=function(x){ is.numeric(x) && (length(x) %in% c(1,2)) && all(is.finite(x)) && all(x == ceiling(x)) && all(x > 1) }, valid="an integer, or a pair of integers, greater than 1" ), nvoxel=list( ## default total number of voxels default=2^22, check=function(x) { is.numeric(x) && length(x) == 1 && all(x == ceiling(x)) && all(x > 2^12) }, valid="a single integer, greater than 2^12" ), old.morpho.psp=list( ## use old code for morphological operations default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), par.binary=list( ## default graphics parameters for masks default=list(), check=is.list, valid="a list" ), par.contour=list( ## default graphics parameters for 'contour' default=list(), check=is.list, valid="a list" ), par.fv=list( ## default graphics parameters for 'plot.fv' default=list(), check=is.list, valid="a list" ), par.persp=list( ## default graphics parameters for 'persp' plots default=list(), check=is.list, valid="a list" ), par.points=list( ## default graphics parameters for 'points' default=list(), check=function(x) { if(!is.list(x)) return(FALSE) nama <- names(x) a <- c("maxsize", "meansize", "markscale") b <- c("minsize", "zerosize") hit <- !is.na(match(a, nama)) if(sum(hit) > 1) return(FALSE) hit <- !is.na(match(b, nama)) if(sum(hit) > 1) return(FALSE) return(TRUE) }, valid=paste("a list containing arguments to points.default", "and/or containing at most one of the parameters", "'maxsize', 'meansize' or 'markscale', and", "at most one of the parameters", "'minsize' or 'zerosize'") ), par.pp3=list( ## default graphics parameters for 'plot.pp3' default=list(), check=is.list, valid="a list" ), print.ppm.SE=list( ## under what conditions to print estimated SE in print.ppm default="poisson", check=function(x) { is.character(x) && length(x) == 1 && all(x %in% c("always", "poisson", "never")) }, valid="one of the strings \'always\', \'poisson\' or \'never\'" ), progress = list( ## how to display progress reports default="tty", check=function(x){ all(x %in% c("tty", "tk", "txtbar")) }, valid="one of the strings 'tty', 'tk' or 'txtbar'" ), project.fast=list( ## whether to cut corners when projecting an invalid ppm object default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), psstA.ngrid=list( ## size of point grid for computing areas in psstA default=32, check=function(x) { is.numeric(x) && length(x) == 1 && all(x == ceiling(x)) && all(x >= 8) }, valid="a single integer, greater than or equal to 8" ), psstA.nr=list( ## number of 'r' values to consider in psstA default=30, check=function(x) { is.numeric(x) && length(x) == 1 && all(x == ceiling(x)) && all(x >= 4) }, valid="a single integer, greater than or equal to 4" ), psstG.remove.zeroes=list( ## whether to remove zero distances in psstG default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), eroded.intensity=list( ## whether to compute intensity estimate in eroded window ## e.g. for Kcom, Gcom default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), rmh.nrep=list( ## default value of parameter 'nrep' in rmh default=5e5, check=function(x) { is.numeric(x) && length(x) == 1 && all(x == ceiling(x)) && all(x > 0) }, valid="a single integer, greater than 0" ), rmh.p=list( ## default value of parameter 'p' in rmh default=0.9, check=function(x) { is.numeric(x) && length(x) == 1 && all(x >= 0) && all(x <= 1) }, valid="a single numerical value, between 0 and 1" ), rmh.q=list( ## default value of parameter 'q' in rmh default=0.9, check=function(x) { is.numeric(x) && length(x) == 1 && all(x > 0) && all(x < 1) }, valid="a single numerical value, strictly between 0 and 1" ), scalable = list( ## whether certain calculations in ppm should be scalable default=TRUE, check=function(x) { is.logical(x) && length(x) == 1}, valid="a single logical value" ), selfcrossing.psp.useCall=list( ## whether to use new code in selfcrossing.psp default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), terse = list( ## Level of terseness in printed output (higher => more terse) default=0, check=function(x) { length(x) == 1 && all(x %in% 0:4) }, valid="an integer between 0 and 4" ), transparent=list( ## whether to allow transparent colours in default colour maps default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), units.paren=list( default="(", check=function(x) { is.character(x) && (length(x) == 1) && all(x %in% c("(", "[", "{", "")) }, valid="one of the strings '(', '[', '{' or '' " ), use.Krect=list( ## whether to use function Krect in Kest(X) when window is rectangle default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), Cwhist=list( ## whether to use C code for whist default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), Cbdrymask=list( ## whether to use C code for bdry.mask default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), kppm.adjusted=list( ## experimental default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), kppm.canonical=list( ## whether to use 'canonical' parameters in kppm default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), kppm.strict=list( ## whether to apply domain limits for cluster parameters in kppm default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), check.RandomFields.loaded=list( # defunct default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), check.RandomFieldsUtils.loaded=list( # defunct default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), check.rpanel.loaded=list( # internal debugging default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), check.rpart.loaded=list( # safety default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), check.glmnet.loaded=list( # safety default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), check.nleqslv.loaded=list( # developmental default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), Clinequad = list( # use C code for 'linequad' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), Ccountends = list( # use C code for 'countends' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), Clinearradius = list( # use C code for 'boundingradius.linnet' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), Cnndistlpp = list( # use C code for 'nndist.lpp'/'nnwhich.lpp' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), Cnncrosslpp = list( # use C code for 'nncross.lpp' default=TRUE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ), developer = list( # general purpose; user is a developer; use experimental code, etc default=FALSE, check=function(x) { is.logical(x) && length(x) == 1 }, valid="a single logical value" ) ) # end of options list reset.spatstat.options <- function() { Spatstat.Options <- lapply(.Spat.Stat.Opt.Table, getElement, name="default") putSpatstatVariable("Spatstat.Options", Spatstat.Options) invisible(Spatstat.Options) } reset.spatstat.options() spatstat.options <- local({ spatstat.options <- function (...) { Spatstat.Options <- getSpatstatVariable("Spatstat.Options") called <- list(...) if(length(called) == 0) { # return all options, except superseded ones allofem <- .Spat.Stat.Opt.Table[names(Spatstat.Options)] retain <- sapply(lapply(allofem, getElement, name="superseded"), is.null) return(Spatstat.Options[retain]) } if(is.null(names(called)) && length(called)==1) { # spatstat.options(x) x <- called[[1]] if(is.null(x)) return(Spatstat.Options) # spatstat.options(NULL) if(is.list(x)) called <- x } if(is.null(names(called))) { # spatstat.options("par1", "par2", ...) ischar <- unlist(lapply(called, is.character)) if(all(ischar)) { choices <- unlist(called) ok <- choices %in% names(Spatstat.Options) if(!all(ok)) stop(paste("Unrecognised option(s):", called[!ok])) if(length(called) == 1) return(Spatstat.Options[[choices]]) else return(Spatstat.Options[choices]) } else { wrong <- called[!ischar] offending <- sapply(wrong, ShortDeparse) offending <- paste(offending, collapse=",") stop(paste("Unrecognised mode of argument(s) [", offending, "]: should be character string or name=value pair")) } } ## spatstat.options(name=value, name2=value2,...) assignto <- names(called) if (is.null(assignto) || !all(nzchar(assignto))) stop("options must all be identified by name=value") recog <- assignto %in% names(.Spat.Stat.Opt.Table) if(!all(recog)) stop(paste("Unrecognised option(s):", assignto[!recog])) ## validate new values for(i in seq_along(assignto)) { nama <- assignto[i] valo <- called[[i]] entry <- .Spat.Stat.Opt.Table[[nama]] ok <- entry$check(valo) if(!ok) stop(paste("Parameter", dQuote(nama), "should be", entry$valid)) } ## reassign changed <- Spatstat.Options[assignto] Spatstat.Options[assignto] <- called putSpatstatVariable("Spatstat.Options", Spatstat.Options) ## return invisible(changed) } ShortDeparse <- function(x) { y <- x dont.complain.about(y) short.deparse(substitute(y)) } spatstat.options }) spatstat.geom/R/split.ppx.R0000644000176200001440000001117514611065352015340 0ustar liggesusers# # split.ppx.R # # $Revision: 1.8 $ $Date: 2021/11/15 03:09:01 $ # # split.ppx etc # ######################################### split.ppx <- function(x, f = marks(x), drop=FALSE, un=NULL, ...) { stopifnot(inherits(x, "ppx")) mf <- markformat(x) if(is.null(un)) un <- missing(f) && !(mf %in% c("dataframe", "hyperframe")) if(missing(f)) { # f defaults to marks of x switch(mf, none={ stop("f is missing and there are no marks") }, vector={ if(!is.multitype(x)) stop("f is missing and the pattern is not multitype") f <- fsplit <- marks(x) }, hyperframe=, dataframe={ f <- fsplit <- firstfactor(marks(x)) if(is.null(f)) stop("Marks do not include a factor") }) splittype <- "factor" } else{ # f was given fsplit <- f if(is.factor(f)) { splittype <- "factor" } else if(is.logical(f)) { splittype <- "factor" f <- factor(f) } else if(is.character(f) && length(f) == 1) { # f should be 'marks' or the name of a column of marks marx <- marks(x) switch(markformat(x), none = { stop(paste("The name", sQuote(f), "does not specify a column of marks", "(there are no marks)"), call.=FALSE) }, vector = { if(f != "marks") stop(paste("The name", sQuote(f), "does not specify a column of marks", "(the marks are a vector)"), call.=FALSE) fsplit <- f <- as.factor(marx) }, dataframe = , hyperframe = { if(!(f %in% colnames(marx))) stop(paste("The name", sQuote(f), "does not match any column of marks"), call.=FALSE) fsplit <- f <- as.factor(marx[,f, drop=TRUE]) }, stop(paste("The name", sQuote(f), "is not recognised as a column of marks"), call.=FALSE) ) splittype <- "factor" } else stop(paste("f must be", "a factor,", "or the name of a column of marks")) if(length(f) != npoints(x)) stop("length(f) must equal the number of points in x") } # At this point # 'f' is a factor that can be used to separate the points # 'fsplit' is the object (either a factor or a tessellation) # that determines the split (and can be "un-split") lev <- levels(f) if(drop) { # remove components that don't contain points retain <- (table(f) > 0) lev <- lev[retain] switch(splittype, factor = { # delete levels that don't occur fsplit <- factor(fsplit, levels=lev) }, stop("Internal error: wrong format for fsplit")) } # split the data out <- list() for(l in lev) out[[paste(l)]] <- x[!is.na(f) & (f == l)] if(un) out <- lapply(out, unmark) class(out) <- c("splitppx", "anylist", class(out)) attr(out, "fsplit") <- fsplit return(out) } print.splitppx <- function(x, ...) { f <- attr(x, "fsplit") what <- if(is.factor(f)) "factor" else "unknown data" cat(paste("Multidimensional point pattern split by", what, "\n")) nam <- names(x) for(i in seq_along(x)) { cat(paste("\n", nam[i], ":\n", sep="")) print(x[[i]]) } return(invisible(NULL)) } summary.splitppx <- function(object, ...) { x <- lapply(object, summary, ...) class(x) <- "summary.splitppx" x } print.summary.splitppx <- function(x, ...) { class(x) <- "anylist" print(x) invisible(NULL) } "[.splitppx" <- function(x, ...) { f <- attr(x, "fsplit") # invoke list method on x class(x) <- "list" y <- x[...] # then make it a 'splitppx' object too class(y) <- c("splitppx", class(y)) if(is.factor(f)) { lev <- levels(f) sublev <- lev[...] subf <- f[f %in% sublev] fsplit <- factor(subf, levels=lev) } else stop("Unknown splitting type") attr(y, "fsplit") <- fsplit y } "[<-.splitppx" <- function(x, ..., value) { if(!all(unlist(lapply(value, is.ppx)))) stop("replacement value must be a list of point patterns (ppx)") f <- attr(x, "fsplit") # invoke list method class(x) <- "list" x[...] <- value # then make it a 'splitppx' object too class(x) <- c("splitppx", class(x)) if(is.factor(f)) { lev <- levels(f) fsplit <- factor(rep.int(lev, unlist(lapply(x, npoints))), levels=lev) } attr(x, "fsplit") <- fsplit x } spatstat.geom/R/pointsonlines.R0000644000176200001440000000320514611065352016276 0ustar liggesusers# # pointsonlines.R # # place points at regular intervals along line segments # # $Revision: 1.9 $ $Date: 2020/03/16 10:28:51 $ # pointsOnLines <- function(X, eps=NULL, np=1000, shortok=TRUE) { stopifnot(is.psp(X)) len <- lengths_psp(X) nseg <- length(len) if(is.null(eps)) { stopifnot(is.numeric(np) && length(np) == 1) stopifnot(is.finite(np) && np > 0) eps <- sum(len)/np } else { stopifnot(is.numeric(eps) && length(eps) == 1) stopifnot(is.finite(eps) && eps > 0) } # initialise Xdf <- as.data.frame(X) xmid <- with(Xdf, (x0+x1)/2) ymid <- with(Xdf, (y0+y1)/2) # handle very short segments # allsegs <- 1:nseg if(any(short <- (len <= eps)) && shortok) { # very short segments: use midpoints Z <- data.frame(x = xmid[short], y = ymid[short], seg=which(short), tp=0.5) } else Z <- data.frame(x=numeric(0), y=numeric(0), seg=integer(0), tp=numeric(0)) # handle other segments for(i in (1:nseg)[!short]) { # divide segment into pieces of length eps # with shorter bits at each end leni <- len[i] nwhole <- floor(leni/eps) if(leni/eps - nwhole < 0.5 && nwhole > 2) nwhole <- nwhole - 1 rump <- (leni - nwhole * eps)/2 brks <- c(0, rump + (0:nwhole) * eps, leni) nbrks <- length(brks) # points at middle of each piece ss <- (brks[-1] + brks[-nbrks])/2 tp <- ss/leni x <- with(Xdf, x0[i] + tp * (x1[i]-x0[i])) y <- with(Xdf, y0[i] + tp * (y1[i]-y0[i])) Z <- rbind(Z, data.frame(x=x, y=y, seg=i, tp=tp)) } result <- as.ppp(Z[,c("x","y")], W=X$window) attr(result, "map") <- Z[,c("seg", "tp")] return(result) } spatstat.geom/R/pointweights.R0000644000176200001440000000340514611065352016120 0ustar liggesusers#' pointweights.R #' #' get a valid vector of weights for a point pattern #' #' Argument 'weights' is usually passed from a user-level function #' It may be: #' a numeric vector #' a numeric matrix or data frame (if dfok=TRUE) #' a single number #' a function(x,y) #' a pixel image #' an expression involving the coordinates and marks #' #' $Revision: 1.4 $ $Date: 2023/12/08 06:51:20 $ pointweights <- function(X, ..., weights=NULL, parent=NULL, dfok=FALSE) { if(is.null(weights)) return(NULL) nX <- npoints(X) ## evaluate weights if(is.numeric(weights) && is.vector(as.numeric(weights))) { if(length(weights) == 1) weights <- rep(weights, nX) } else if(is.im(weights)) { weights <- safelookup(weights, X) # includes warning if NA } else if(is.function(weights)) { weights <- weights(X$x, X$y) } else if(is.expression(weights)) { #' evaluate expression in data frame of coordinates and marks df <- as.data.frame(X) weights <- try(eval(weights, envir=df, enclos=parent)) if(inherits(weights, "try-error")) stop("Unable to evaluate expression for weights", call.=FALSE) } else if(dfok && inherits(weights, c("matrix", "data.frame"))) { weights <- as.matrix(weights) } else stop(paste0("Argument 'weights' should be ", "a numeric vector, ", if(dfok) "matrix or data frame, " else NULL, "a function, an image, or an expression"), call.=FALSE) ## trivial weights are returned as NULL if(length(weights) == 0) return(NULL) ## validate if(dfok && !is.null(dim(weights))) { check.nmatrix(weights, nX, squarematrix=FALSE, mname="weights") } else { check.nvector(weights, nX, vname="weights") } return(weights) } spatstat.geom/R/nearestsegment.R0000644000176200001440000000506114611065352016420 0ustar liggesusers# # nearestsegment.R # # $Revision: 1.12 $ $Date: 2018/03/07 01:56:36 $ # # Given a point pattern X and a line segment pattern Y, # for each point x of X, determine which segment of Y is closest to x # and find the point on Y closest to x. # nearestsegment <- function(X,Y) { return(ppllengine(X,Y,"identify")) } project2segment <- function(X, Y) { return(ppllengine(X,Y,"project")) } ppllengine <- function(X, Y, action="project", check=FALSE) { stopifnot(is.ppp(X)) stopifnot(is.psp(Y)) stopifnot(action %in% c("distance", "identify", "project")) # deal with empty patterns if(X$n == 0) { nowt <- numeric(0) none <- integer(0) switch(action, identify = return(none), distance = return(list(dist=nowt, which=none)), project = return(list(Xproj=X, mapXY=none, d=nowt, tp=nowt))) } if(Y$n == 0) stop("Segment pattern Y contains 0 segments; projection undefined") # XX <- as.matrix(as.data.frame(unmark(X))) YY <- as.matrix(as.data.frame(unmark(Y))) # determine which segment lies closest to each point huge <- max(diameter(as.rectangle(as.owin(X))), diameter(as.rectangle(as.owin(Y)))) d <- distppllmin(XX, YY, huge^2) mapXY <- d$min.which if(action == "identify") return(mapXY) else if(action == "distance") return(data.frame(dist=d$min.d, which=mapXY)) # combine relevant rows of data alldata <- as.data.frame(cbind(XX, YY[mapXY, ,drop=FALSE])) colnames(alldata) <- c("x", "y", "x0", "y0", "x1", "y1") # coordinate geometry dx <- with(alldata, x1-x0) dy <- with(alldata, y1-y0) leng <- sqrt(dx^2 + dy^2) # rotation sines & cosines (may include 0/0) co <- dx/leng si <- dy/leng # vector to point from first endpoint of segment xv <- with(alldata, x - x0) yv <- with(alldata, y - y0) # rotate coordinate system so that x axis is parallel to line segment xpr <- xv * co + yv * si # ypr <- - xv * si + yv * co # determine whether projection is an endpoint or interior point of segment ok <- is.finite(xpr) left <- !ok | (xpr <= 0) right <- ok & (xpr >= leng) # location of projected point in rotated coordinates xr <- with(alldata, ifelseAX(left, 0, ifelseXY(right, leng, xpr))) # back to standard coordinates xproj <- with(alldata, x0 + ifelseXB(ok, xr * co, 0)) yproj <- with(alldata, y0 + ifelseXB(ok, xr * si, 0)) Xproj <- ppp(xproj, yproj, window=X$window, marks=X$marks, check=check) # parametric coordinates tp <- xr/leng tp[!is.finite(tp)] <- 0 # return(list(Xproj=Xproj, mapXY=mapXY, d=d$min.d, tp=tp)) } spatstat.geom/R/areadiff.R0000644000176200001440000002426214611065351015140 0ustar liggesusers# # areadiff.R # # $Revision: 1.42 $ $Date: 2024/02/04 08:04:51 $ # # Computes sufficient statistic for area-interaction process # # Invokes areadiff.c # # areaLoss = area lost by removing X[i] from X areaLoss <- function(X, r, ..., W=as.owin(X), subset=NULL, exact=FALSE, ngrid=spatstat.options("ngrid.disc")) { if(exact) areaLoss.diri(X, r, ..., W=W, subset=subset) else areaLoss.grid(X, r, ..., W=W, subset=subset, ngrid=ngrid) } # areaGain = area gained by adding u[i] to X areaGain <- function(u, X, r, ..., W=as.owin(X), exact=FALSE, ngrid=spatstat.options("ngrid.disc")) { if(exact) areaGain.diri(u, X, r, ..., W=W) else areaGain.grid(u, X, r, W=W, ..., ngrid=ngrid) } #//////////////////////////////////////////////////////////// # algorithms using polygon geometry #/////////////////////////////////////////////////////////// areaLoss.poly <- function(X, r, ..., W=as.owin(X), subset=NULL, splitem=TRUE) { check.1.real(r) nX <- npoints(X) if(r <= 0 || nX == 0) return(numeric(nX)) cooX <- coords(X) if(useW <- is.owin(W)) W <- as.polygonal(W) #' initialise result result <- rep(pi * r^2, nX) wanted <- 1:nX if(!is.null(subset)) wanted <- wanted[subset] #' split into connected components if(splitem) { Y <- connected(X, 2 * r) Z <- split(Y) V <- lapply(Z, areaLoss.poly, r=r, W=W, splitem=FALSE) return(unsplit(V, marks(Y))[wanted]) } #' determine which pairs of points interact cl <- closepairs(X, 2 * r, what="indices") if(length(cl$i) == 0) return(result[wanted]) #' determine scale parameters for polyclip p <- commonPolyclipArgs(Frame(X)) #' template disc ball0 <- disc(r, c(0,0), ...) #' discs centred on data points balls <- vector(mode="list", length=nX) for(i in seq_len(nX)) balls[[i]] <- shift(ball0, vec=cooX[i,]) balls <- as.solist(balls, check=FALSE) #' start computin' for(i in wanted) { jj <- cl$j[cl$i == i] nn <- length(jj) if(nn > 0) { #' union of balls close to i u <- if(nn == 1) balls[[ jj ]] else union.owin(balls[jj], p=p) #' subtract from ball i v <- setminus.owin(balls[[i]], u) #' clip to window if(useW) v <- intersect.owin(v, W) #' compute result[i] <- area(v) } } return(result[wanted]) } #//////////////////////////////////////////////////////////// # algorithms using Dirichlet tessellation #/////////////////////////////////////////////////////////// areaLoss.diri <- function(X, r, ..., W=as.owin(X), subset=NULL) { stopifnot(is.ppp(X)) npts <- npoints(X) if(is.matrix(r)) { if(sum(dim(r) > 1) > 1) stop("r should be a vector or single value") r <- as.vector(r) } nr <- length(r) if(npts == 0) return(matrix(, nrow=0, ncol=nr)) else if(npts == 1) return(matrix(discpartarea(X, r, W), nrow=1)) #' set up output array indices <- 1L:npts if(!is.null(subset)) indices <- indices[subset] out <- matrix(0, nrow=length(indices), ncol=nr) #' handle duplicate points retain <- !duplicated(X) getzero <- (multiplicity(X) > 1) uX <- X[retain] newserial <- cumsum(retain) # dirichlet neighbour relation in entire pattern w <- X$window dd <- deldir::deldir(uX$x, uX$y, rw=c(w$xrange, w$yrange)) a <- dd$delsgs[,5L] b <- dd$delsgs[,6L] pir2 <- pi * r^2 for(k in seq_along(indices)) { ind <- indices[k] if(!getzero[ind]) { #' find serial number in uX i <- newserial[ind] #' find all Delaunay neighbours of i jj <- c(b[a==i], a[b==i]) jj <- sortunique(jj) #' extract only these points Yminus <- uX[jj] Yplus <- uX[c(jj, i)] #' dilate aplus <- dilated.areas(Yplus, r, W, exact=TRUE, ...) aminus <- dilated.areas(Yminus, r, W, exact=TRUE, ...) areas <- aplus - aminus #' area/(pi * r^2) must be positive and nonincreasing y <- ifelseAX(r == 0, 1, areas/pir2) y <- pmin.int(1, y) ok <- is.finite(y) y[ok] <- rev(cummax(rev(y[ok]))) areas <- pmax.int(0, y * pir2) #' save out[k, ] <- areas } } return(out) } areaGain.diri <- function(u, X, r, ..., W=as.owin(X), verbose=FALSE) { stopifnot(is.ppp(X)) Y <- as.ppp(u, W=W) nX <- X$n nY <- Y$n if(is.matrix(r)) { if(sum(dim(r) > 1) > 1) stop("r should be a vector or single value") r <- as.vector(r) } nr <- length(r) if(nY == 0) return(matrix(, nrow=0, ncol=nr)) if(nX == 0) return(matrix(pi * r^2, nrow=nY, ncol=nr, byrow=TRUE)) if(verbose) splat("areaGain,", nY, ngettext(nY, "point,", "points,"), nr, ngettext(nr, "rvalue", "r values")) out <- matrix(0, nrow=nY, ncol=nr) pir2 <- pi * r^2 wbox <- as.rectangle(as.owin(X)) # state <- list() for(i in 1L:nY) { if(verbose) state <- progressreport(i, nY, state=state) V <- superimpose(Y[i], X, W=wbox, check=FALSE) # Dirichlet neighbour relation for V dd <- deldir(V$x, V$y, rw=c(wbox$xrange, wbox$yrange)) aa <- dd$delsgs[,5L] bb <- dd$delsgs[,6L] # find all Delaunay neighbours of Y[1] in V jj <- c(bb[aa==1L], aa[bb==1L]) jj <- sortunique(jj) # extract only these points Zminus <- V[jj] Zplus <- V[c(1, jj)] # dilate aplus <- dilated.areas(Zplus, r, W, exact=TRUE) aminus <- dilated.areas(Zminus, r, W, exact=TRUE) areas <- aplus - aminus # area/(pi * r^2) must be in [0,1] and nonincreasing y <- ifelseAX(r == 0, 1, areas/pir2) y <- pmin.int(1, y) ok <- is.finite(y) y[ok] <- rev(cummax(rev(y[ok]))) areas <- pmax.int(0, y * pir2) # save out[i,] <- areas } return(out) } #//////////////////////////////////////////////////////////////////////// # alternative implementations using grid counting in C #//////////////////////////////////////////////////////////////////////// areaGain.grid <- function(u, X, r, ..., W=NULL, ngrid=spatstat.options("ngrid.disc")) { verifyclass(X, "ppp") u <- as.ppp(u, W=as.owin(X)) stopifnot(is.numeric(r) && all(is.finite(r)) && all(r >= 0)) # nu <- u$n nr <- length(r) if(nr == 0) return(numeric(0)) rmax <- max(r) # constrain <- !is.null(W) if(constrain && (W$type != "rectangle")) { # Constrained to an irregular window # initialise to value for small-r result <- matrix(pi * r^2, nrow=nu, ncol=nr, byrow=TRUE) # vector of radii below which b(u,r) is disjoint from U(X,r) rcrit.u <- nncross(u, X, what="dist")/2 rcrit.min <- min(rcrit.u) #' determine pixel resolution eps <- unclass(as.mask(Window(X), ...))[c("xstep", "ystep")] eps <- as.numeric(eps) eps <- eps * min(1, (rmax/4)/max(eps)) #' Use distance transform and set covariance D <- distmap(X, eps=eps) DW <- D[W, drop=FALSE] # distance from (0,0) - thresholded to make digital discs discWin <- owinInternalRect(c(-rmax,rmax),c(-rmax,rmax)) discWin <- as.mask(discWin, eps=eps) rad <- as.im(function(x,y){sqrt(x^2+y^2)}, W=discWin) # for(j in which(r > rcrit.min)) { # rj is above the critical radius rcrit.u[i] for at least one point u[i] rj <- r[j] if(any(above <- (rj > rcrit.u))) { Uncovered <- levelset(DW, rj, ">") DiscRj <- levelset(rad, rj, "<=") AreaGainIm <- setcov(Uncovered, DiscRj) result[above, j] <- safelookup(AreaGainIm, u[above]) } } return(result) } # # xx <- X$x yy <- X$y result <- matrix(, nrow=nu, ncol=nr) # for(i in 1L:nu) { # shift u[i] to origin xu <- u$x[i] yu <- u$y[i] xshift <- xx - xu yshift <- yy - yu # find points within distance 2 rmax of origin close <- (xshift^2 + yshift^2 < 4 * rmax^2) nclose <- sum(close) # invoke C routine if(!constrain) { z <- .C(SG_areadifs, rad = as.double(r), nrads = as.integer(nr), x = as.double(xshift[close]), y = as.double(yshift[close]), nn = as.integer(nclose), ngrid = as.integer(ngrid), answer = as.double(numeric(nr)), PACKAGE="spatstat.geom") result[i,] <- z$answer } else { z <- .C(SG_areaBdif, rad = as.double(r), nrads = as.integer(nr), x = as.double(xshift[close]), y = as.double(yshift[close]), nn = as.integer(nclose), ngrid = as.integer(ngrid), x0 = as.double(W$xrange[1L] - xu), y0 = as.double(W$yrange[1L] - yu), x1 = as.double(W$xrange[2L] - xu), y1 = as.double(W$yrange[2L] - yu), answer = as.double(numeric(nr)), PACKAGE="spatstat.geom") result[i,] <- z$answer } } return(result) } areaLoss.grid <- function(X, r, ..., W=as.owin(X), subset=NULL, method = c("count", "distmap"), ngrid = spatstat.options("ngrid.disc"), exact = FALSE) { verifyclass(X, "ppp") n <- npoints(X) nr <- length(r) indices <- if(is.null(subset)) 1L:n else (1L:n)[subset] answer <- matrix(, nrow=length(indices), ncol=nr) if(missing(method)) { method <- if(nr <= 20 || exact) "count" else "distmap" } else method <- match.arg(method) switch(method, count = { # one value of r: use grid-counting for(k in seq_along(indices)) { i <- indices[k] answer[k,] <- areaGain(X[i], X[-i], r, W=W, ngrid=ngrid, exact=exact, ...) } }, distmap = { # Many values of r: use distance transform D <- distmap(X, ...) DW <- D[W, drop=FALSE] a <- area(Window(DW)) # empirical cdf of distance values FW <- ecdf(DW[drop=TRUE]) # radii below which there are no overlaps rcrit <- nndist(X)/2 for(k in seq_along(indices)) { i <- indices[k] Di <- distmap(X[-i], ...) FiW <- ecdf(Di[W, drop=TRUE]) answer[k, ] <- ifelseXY(r > rcrit[i], a * (FW(r) - FiW(r)), pi * r^2) } }) return(answer) } spatstat.geom/R/indicator.R0000644000176200001440000000147114611065352015351 0ustar liggesusers#' indicator function for window as.function.owin <- function(x, ...) { W <- x g <- function(x, y=NULL) { xy <- xy.coords(x, y) inside.owin(xy$x, xy$y, W) } class(g) <- c("indicfun", class(g)) return(g) } print.indicfun <- function(x, ...) { W <- get("W", envir=environment(x)) nama <- names(formals(x)) splat(paste0("function", paren(paste(nama, collapse=",")))) splat("Indicator function (returns 1 inside window, 0 outside)") print(W) return(invisible(NULL)) } plot.indicfun <- function(x, W, ..., main) { if(missing(main)) main <- short.deparse(substitute(x)) if(missing(W) || is.null(W)) { w <- get("W", envir=environment(x)) R <- Frame(w) W <- grow.rectangle(R, min(sidelengths(R))/5) } result <- do.as.im(x, plot, W=W, ..., main=main) return(invisible(result)) } spatstat.geom/R/periodify.R0000644000176200001440000000755514611065352015400 0ustar liggesusers# # periodify.R # # replicate a pattern periodically # # $Revision: 1.4 $ $Date: 2024/02/04 08:04:51 $ # periodify <- function(X, ...) { UseMethod("periodify") } periodify.ppp <- function(X, nx=1, ny=1, ..., combine=TRUE, warn=TRUE, check=TRUE, ix=(-nx):nx, iy=(-ny):ny, ixy=expand.grid(ix=ix,iy=iy)) { # sanity checks if(!missing(nx) || !missing(ny)) { if(is.null(nx)) nx <- 1 if(is.null(ny)) ny <- 1 if(length(nx) != 1 || length(ny) != 1) stop("nx and ny should be single integers") if(nx != round(nx) || ny != round(ny)) stop("nx and ny should be integers") } force(ixy) W <- X$window isrect <- (W$type == "rectangle") if(warn && combine && !isrect) warning("X has a non-rectangular window") else isrect <- isrect && all(diff(nx) == 1) && all(diff(ny) == 1) width <- diff(W$xrange) height <- diff(W$yrange) shifts <- cbind(ixy[,1] * width, ixy[,2] * height) Xshift <- list() for(i in 1:nrow(shifts)) Xshift[[i]] <- shift(X, vec=as.numeric(shifts[i, ])) if(!combine) return(Xshift) Wnew <- if(isrect) { owinInternalRect(range(range(W$xrange) + range(shifts[,1])), range(range(W$yrange) + range(shifts[,2]))) } else NULL Z <- do.call(superimpose, append(Xshift, list(W=Wnew, check=check))) return(Z) } periodify.psp <- function(X, nx=1, ny=1, ..., combine=TRUE, warn=TRUE, check=TRUE, ix=(-nx):nx, iy=(-ny):ny, ixy=expand.grid(ix=ix,iy=iy)) { # sanity checks if(!missing(nx) || !missing(ny)) { if(is.null(nx)) nx <- 1 if(is.null(ny)) ny <- 1 if(length(nx) != 1 || length(ny) != 1) stop("nx and ny should be single integers") if(nx != round(nx) || ny != round(ny)) stop("nx and ny should be integers") } force(ixy) W <- X$window isrect <- (W$type == "rectangle") if(warn && combine && !isrect) warning("X has a non-rectangular window") else isrect <- isrect && all(diff(nx) == 1) && all(diff(ny) == 1) width <- diff(W$xrange) height <- diff(W$yrange) shifts <- cbind(ixy[,1] * width, ixy[,2] * height) Xshift <- list() for(i in 1:nrow(shifts)) Xshift[[i]] <- shift(X, vec=as.numeric(shifts[i, ])) if(!combine) return(Xshift) Wnew <- if(isrect) { owinInternalRect(range(range(W$xrange) + range(shifts[,1])), range(range(W$yrange) + range(shifts[,2]))) } else NULL Z <- do.call(superimpose, append(Xshift, list(W=Wnew, check=check))) return(Z) } periodify.owin <- function(X, nx=1, ny=1, ..., combine=TRUE, warn=TRUE, ix=(-nx):nx, iy=(-ny):ny, ixy=expand.grid(ix=ix,iy=iy)) { # sanity checks if(!missing(nx) || !missing(ny)) { if(is.null(nx)) nx <- 1 if(is.null(ny)) ny <- 1 if(length(nx) != 1 || length(ny) != 1) stop("nx and ny should be single integers") if(nx != round(nx) || ny != round(ny)) stop("nx and ny should be integers") } force(ixy) isrect <- (X$type == "rectangle") if(warn && combine && !isrect) warning("X is not rectangular") else isrect <- isrect && all(diff(nx) == 1) && all(diff(ny) == 1) width <- diff(X$xrange) height <- diff(X$yrange) shifts <- cbind(ixy[,1] * width, ixy[,2] * height) if(combine) { if(isrect) { # result is a rectangle Y <- owinInternalRect(range(range(X$xrange) + range(shifts[,1])), range(range(X$yrange) + range(shifts[,2]))) } else { # result is another type of window for(i in 1:nrow(shifts)) { Xi <- shift(X, vec=as.numeric(shifts[i, ])) Y <- if(i == 1) Xi else union.owin(Y, Xi) } } } else { # result is a list Y <- list() for(i in 1:nrow(shifts)) Y[[i]] <- shift(X, vec=as.numeric(shifts[i, ])) } return(Y) } spatstat.geom/R/summary.im.R0000644000176200001440000001020014611065352015464 0ustar liggesusers# # summary.im.R # # summary() method for class "im" # # $Revision: 1.22 $ $Date: 2022/01/04 05:30:06 $ # # summary.im() # print.summary.im() # print.im() # summary.im <- function(object, ...) { verifyclass(object, "im") x <- object y <- unclass(x)[c("dim", "xstep", "ystep")] pixelarea <- y$xstep * y$ystep # extract image values v <- x$v inside <- !is.na(v) v <- v[inside] empty <- !any(inside) # type of values? y$type <- x$type if(!empty) { #' factor-valued? lev <- levels(x) if(!is.null(lev) && !is.factor(v)) v <- factor(v, levels=seq_along(lev), labels=lev) switch(x$type, integer=, real={ y$mean <- mv <- mean(v) y$integral <- mv * length(v) * pixelarea y$range <- ra <- range(v) y$min <- ra[1] y$max <- ra[2] }, factor={ y$levels <- lev y$table <- table(v, dnn="") }, complex={ y$mean <- mv <- mean(v) y$integral <- mv * length(v) * pixelarea rr <- range(Re(v)) y$Re <- list(range=rr, min=rr[1], max=rr[2]) ri <- range(Im(v)) y$Im <- list(range=ri, min=ri[1], max=ri[2]) }, { #' another unknown type pixelvalues <- v y$summary <- summary(pixelvalues) }) } #' summarise pixel raster win <- as.owin(x) y$window <- summary.owin(win) y$empty <- empty y$fullgrid <- !empty && (rescue.rectangle(win)$type == "rectangle") y$units <- unitname(x) class(y) <- "summary.im" return(y) } print.summary.im <- function(x, ...) { verifyclass(x, "summary.im") splat(paste0(x$type, "-valued"), "pixel image") unitinfo <- summary(x$units) pluralunits <- unitinfo$plural sigdig <- getOption('digits') di <- x$dim win <- x$window splat(di[1], "x", di[2], "pixel array (ny, nx)") splat("enclosing rectangle:", prange(signif(x$window$xrange, sigdig)), "x", prange(signif(x$window$yrange, sigdig)), unitinfo$plural, unitinfo$explain) splat("dimensions of each pixel:", signif(x$xstep, 3), "x", signif(x$ystep, sigdig), pluralunits) if(!is.null(explain <- unitinfo$explain)) splat(explain) fullgrid <- x$fullgrid empty <- x$empty if(fullgrid) { splat("Image is defined on the full rectangular grid") whatpart <- "Frame" } else if(!empty) { splat("Image is defined on a subset of the rectangular grid") whatpart <- "Subset" } else { splat("Image is empty (all pixel values are undefined)") return(invisible(NULL)) } splat(whatpart, "area =", win$area, "square", pluralunits) if(!fullgrid) { af <- signif(win$areafraction, min(3, sigdig)) splat(whatpart, "area fraction =", af) } if(fullgrid) splat("Pixel values") else splat("Pixel values (inside window):") switch(x$type, integer=, real={ splat("\trange =", prange(signif(x$range, sigdig))) splat("\tintegral =", signif(x$integral, sigdig)) splat("\tmean =", signif(x$mean, sigdig)) }, factor={ print(x$table) }, complex={ splat("\trange: Real", prange(signif(x$Re$range, sigdig)), "Imaginary", prange(signif(x$Im$range, sigdig))) splat("\tintegral =", signif(x$integral, sigdig)) splat("\tmean =", signif(x$mean, sigdig)) }, { print(x$summary) }) return(invisible(NULL)) } print.im <- function(x, ...) { splat(paste0(x$type, "-valued"), "pixel image") if(x$type == "factor") { splat("factor levels:") print(levels(x)) } sigdig <- min(5, getOption('digits')) unitinfo <- summary(unitname(x)) di <- x$dim splat(di[1], "x", di[2], "pixel array (ny, nx)") splat("enclosing rectangle:", prange(signif(zapsmall(x$xrange), sigdig)), "x", prange(signif(zapsmall(x$yrange), sigdig)), unitinfo$plural, unitinfo$explain) return(invisible(NULL)) } spatstat.geom/R/rescue.rectangle.R0000644000176200001440000000142514611065352016625 0ustar liggesusers# # rescue.rectangle.R # # $Revision: 1.8 $ $Date: 2024/02/04 08:04:51 $ # rescue.rectangle <- function(W) { verifyclass(W, "owin") if(W$type == "mask" && all(W$m)) return(owinInternalRect(W$xrange, W$yrange, unitname=unitname(W))) if(W$type == "polygonal" && length(W$bdry) == 1) { x <- W$bdry[[1]]$x y <- W$bdry[[1]]$y if(length(x) == 4 && length(y) == 4) { # could be a rectangle ux <- veryunique(x) uy <- veryunique(y) if(length(ux) == 2 && length(uy) == 2) return(owinInternalRect(ux,uy, unitname=unitname(W))) } } return(W) } veryunique <- function(z) { uz <- sortunique(z) epsilon <- 2 * .Machine$double.eps * diff(range(uz)) close <- (diff(uz) <= epsilon) uz <- uz[c(TRUE, !close)] return(uz) } spatstat.geom/R/hasclose.R0000644000176200001440000001240714611065352015177 0ustar liggesusers#' #' hasclose.R #' #' Determine whether each point has a close neighbour #' #' $Revision: 1.13 $ $Date: 2022/05/21 09:52:11 $ has.close <- function(X, r, Y=NULL, ...) { UseMethod("has.close") } has.close.default <- function(X, r, Y=NULL, ..., periodic=FALSE) { trap.extra.arguments(...) if(!periodic) { nd <- if(is.null(Y)) nndist(X) else nncross(X, Y, what="dist") return(nd <= r) } if(is.null(Y)) { pd <- pairdist(X, periodic=TRUE) diag(pd) <- Inf } else { pd <- crossdist(X, Y, periodic=TRUE) } # return(apply(pd <= r, 1, any)) return(matrowany(pd <= r)) } has.close.ppp <- function(X, r, Y=NULL, ..., periodic=FALSE, sorted=FALSE) { trap.extra.arguments(...) nX <- npoints(X) if(nX <= 1) return(logical(nX)) #' sort by increasing x coordinate cX <- coords(X) if(!sorted) { oo <- order(cX$x) cX <- cX[oo,,drop=FALSE] } if(is.null(Y)) { if(!periodic) { zz <- .C(SG_hasXclose, n = as.integer(nX), x = as.double(cX$x), y = as.double(cX$y), r = as.double(r), t = as.integer(integer(nX)), PACKAGE="spatstat.geom") } else { b <- sidelengths(Frame(X)) zz <- .C(SG_hasXpclose, n = as.integer(nX), x = as.double(cX$x), y = as.double(cX$y), r = as.double(r), b = as.double(b), t = as.integer(integer(nX)), PACKAGE="spatstat.geom") } } else { stopifnot(is.ppp(Y)) nY <- npoints(Y) if(nY == 0) return(logical(nX)) cY <- coords(Y) #' sort Y by increasing x coordinate if(!sorted) { ooY <- order(cY$x) cY <- cY[ooY, , drop=FALSE] } if(!periodic) { zz <- .C(SG_hasXYclose, n1 = as.integer(nX), x1 = as.double(cX$x), y1 = as.double(cX$y), n2 = as.integer(nY), x2 = as.double(cY$x), y2 = as.double(cY$y), r = as.double(r), t = as.integer(integer(nX)), PACKAGE="spatstat.geom") } else { bX <- sidelengths(Frame(X)) bY <- sidelengths(Frame(Y)) if(any(bX != bY)) warning("Windows are not equal: periodic distance may be erroneous") zz <- .C(SG_hasXYpclose, n1 = as.integer(nX), x1 = as.double(cX$x), y1 = as.double(cX$y), n2 = as.integer(nY), x2 = as.double(cY$x), y2 = as.double(cY$y), r = as.double(r), b = as.double(bX), t = as.integer(integer(nX)), PACKAGE="spatstat.geom") } } tt <- as.logical(zz$t) if(sorted) return(tt) #' reinstate original order ans <- logical(nX) ans[oo] <- tt return(ans) } has.close.pp3 <- function(X, r, Y=NULL, ..., periodic=FALSE, sorted=FALSE) { trap.extra.arguments(...) nX <- npoints(X) if(nX <= 1) return(logical(nX)) cX <- coords(X) if(!sorted) { #' sort by increasing x coordinate oo <- order(cX$x) cX <- cX[oo,,drop=FALSE] } if(is.null(Y)) { if(!periodic) { zz <- .C(SG_hasX3close, n = as.integer(nX), x = as.double(cX$x), y = as.double(cX$y), z = as.double(cX$z), r = as.double(r), t = as.integer(integer(nX)), PACKAGE="spatstat.geom") } else { b <- sidelengths(as.box3(X)) zz <- .C(SG_hasX3pclose, n = as.integer(nX), x = as.double(cX$x), y = as.double(cX$y), z = as.double(cX$z), r = as.double(r), b = as.double(b), t = as.integer(integer(nX)), PACKAGE="spatstat.geom") } } else { stopifnot(is.pp3(Y)) nY <- npoints(Y) if(nY == 0) return(logical(nX)) cY <- coords(Y) if(!sorted) { #' sort Y by increasing x coordinate ooY <- order(cY$x) cY <- cY[ooY, , drop=FALSE] } if(!periodic) { zz <- .C(SG_hasXY3close, n1 = as.integer(nX), x1 = as.double(cX$x), y1 = as.double(cX$y), z1 = as.double(cX$z), n2 = as.integer(nY), x2 = as.double(cY$x), y2 = as.double(cY$y), z2 = as.double(cY$z), r = as.double(r), t = as.integer(integer(nX)), PACKAGE="spatstat.geom") } else { bX <- sidelengths(as.box3(X)) bY <- sidelengths(as.box3(Y)) if(any(bX != bY)) warning("Domains are not equal: periodic distance may be erroneous") zz <- .C(SG_hasXY3pclose, n1 = as.integer(nX), x1 = as.double(cX$x), y1 = as.double(cX$y), z1 = as.double(cX$z), n2 = as.integer(nY), x2 = as.double(cY$x), y2 = as.double(cY$y), z2 = as.double(cY$z), r = as.double(r), b = as.double(bX), t = as.integer(integer(nX)), PACKAGE="spatstat.geom") } } tt <- as.logical(zz$t) if(sorted) return(tt) #' reinstate original order ans <- logical(nX) ans[oo] <- tt return(ans) } spatstat.geom/R/logiquad.R0000644000176200001440000001114614611065352015202 0ustar liggesusers#' #' logiquad.R #' #' Quadrature schemes for logistic method #' #' $Revision: 1.3 $ $Date: 2020/11/29 08:59:00 $ logi.dummy <- function(X, dummytype = "stratrand", nd = NULL, mark.repeat = FALSE, ...){ ## Resolving nd inspired by default.n.tiling if(is.null(nd)){ nd <- spatstat.options("ndummy.min") if(inherits(X, "ppp")) nd <- pmax(nd, 10 * ceiling(2 * sqrt(X$n)/10)) } nd <- ensure2vector(nd) marx <- is.multitype(X) if(marx) lev <- levels(marks(X)) if(marx && mark.repeat){ N <- length(lev) Dlist <- inDlist <- vector("list", N) } else{ N <- 1 } W <- as.owin(X) type <- match.arg(dummytype, c("stratrand", "binomial", "poisson", "grid", "transgrid")) B <- boundingbox(W) ndumB <- nd[1L] * nd[2L] rho <- ndumB/area(B) Dinfo <- list(nd=nd, rho=rho, how=type) ## Repeating dummy process for each mark type 1:N (only once if unmarked or mark.repeat = FALSE) for(i in 1:N){ switch(type, stratrand={ D <- as.ppp(stratrand(B, nd[1L], nd[2L]), W = B) inD <- which(inside.owin(D, w = W)) D <- D[W] inD <- paste(i,inD,sep="_") }, binomial={ D <- runifrect(ndumB, win=B) D <- D[W] }, poisson={ D <- runifrect(rpois(1, ndumB), win=B) D <- D[W] }, grid={ D <- as.ppp(gridcenters(B, nd[1L], nd[2L]), W = B) inD <- which(inside.owin(D, w = W)) D <- D[W] inD <- paste(i,inD,sep="_") }, transgrid={ D <- as.ppp(gridcenters(B, nd[1L], nd[2L]), W = B) dxy <- c(diff(D$window$xrange),diff(D$window$yrange))/(2*nd) coords(D) <- coords(D)+matrix(runif(2,-dxy,dxy),npoints(D),2,byrow=TRUE) inD <- which(inside.owin(D, w = W)) D <- D[W] inD <- paste(i,inD,sep="_") }, stop("unknown dummy type")) if(marx && mark.repeat){ marks(D) <- factor(lev[i], levels = lev) Dlist[[i]] <- D if(type %in% c("stratrand","grid","transgrid")) inDlist[[i]] <- inD } } if(marx && mark.repeat){ inD <- Reduce(append, inDlist) D <- Reduce(superimpose, Dlist) } if(type %in% c("stratrand","grid","transgrid")) Dinfo <- append(Dinfo, list(inD=inD)) if(marx && !mark.repeat){ marks(D) <- sample(factor(lev, levels=lev), npoints(D), replace = TRUE) Dinfo$rho <- Dinfo$rho/length(lev) } attr(D, "dummy.parameters") <- Dinfo return(D) } quadscheme.logi <- function(data, dummy, dummytype = "stratrand", nd = NULL, mark.repeat = FALSE, ...){ data <- as.ppp(data) ## If dummy is missing we generate dummy pattern with logi.dummy. if(missing(dummy)) dummy <- logi.dummy(data, dummytype, nd, mark.repeat, ...) Dinfo <- attr(dummy, "dummy.parameters") D <- as.ppp(dummy) if(is.null(Dinfo)) Dinfo <- list(how="given", rho=npoints(D)/(area(D)*markspace.integral(D))) ## Weights: n <- npoints(data)+npoints(D) w <- area(Window(data))/n Q <- quad(data, D, rep(w,n), param=Dinfo) class(Q) <- c("logiquad", class(Q)) return(Q) } summary.logiquad <- function(object, ..., checkdup=FALSE) { verifyclass(object, "logiquad") s <- list( data = summary.ppp(object$data, checkdup=checkdup), dummy = summary.ppp(object$dummy, checkdup=checkdup), param = object$param) class(s) <- "summary.logiquad" return(s) } print.summary.logiquad <- function(x, ..., dp=3) { cat("Quadrature scheme (logistic) = data + dummy\n") Dinfo <- x$param if(is.null(Dinfo)) cat("created by an unknown function.\n") cat("Data pattern:\n") print(x$data, dp=dp) cat("\n\nDummy pattern:\n") # How they were computed switch(Dinfo$how, stratrand={ cat(paste("(Stratified random dummy points,", paste(Dinfo$nd, collapse=" x "), "grid of cells)\n")) }, binomial={ cat("(Binomial dummy points)\n") }, poisson={ cat("(Poisson dummy points)\n") }, grid={ cat(paste("(Fixed grid of dummy points,", paste(Dinfo$nd, collapse=" x "), "grid)\n")) }, transgrid={ cat(paste("(Random translation of fixed grid of dummy points,", paste(Dinfo$nd, collapse=" x "), "grid)\n")) }, given=cat("(Dummy points given by user)\n") ) # Description of them print(x$dummy, dp=dp) return(invisible(NULL)) } spatstat.geom/R/levelset.R0000644000176200001440000000235314611065352015220 0ustar liggesusers# levelset.R # # $Revision: 1.5 $ $Date: 2015/01/15 07:10:37 $ # # level set of an image levelset <- function(X, thresh, compare="<=") { # force X and thresh to be evaluated in this frame verifyclass(X, "im") thresh <- thresh switch(compare, "<" = { A <- eval.im(X < thresh) }, ">" = { A <- eval.im(X > thresh) }, "<=" = { A <- eval.im(X <= thresh) }, ">=" = { A <- eval.im(X >= thresh) }, "==" = { A <- eval.im(X == thresh) }, "!=" = { A <- eval.im(X != thresh) }, stop(paste("unrecognised comparison operator", sQuote(compare)))) W <- as.owin(eval.im(ifelse1NA(A))) return(W) } # compute owin containing all pixels where image expression is TRUE solutionset <- function(..., envir) { if(missing(envir)) envir <- parent.frame() A <- try(eval.im(..., envir=envir), silent=TRUE) if(inherits(A, "try-error")) A <- try(eval(..., envir=envir), silent=TRUE) if(inherits(A, "try-error")) stop("Unable to evaluate expression") if(!is.im(A)) stop("Evaluating the expression did not yield a pixel image") if(A$type != "logical") stop("Evaluating the expression did not yield a logical-valued image") W <- as.owin(eval.im(ifelse1NA(A))) return(W) } spatstat.geom/R/nnutils.R0000644000176200001440000001223214611065352015066 0ustar liggesusers#' #' nnutils.R #' #' Utilities for extracting nndist/nncross from distance matrices #' #' $Revision: 1.4 $ $Date: 2022/02/12 06:12:14 $ PDtoNN <- function(d, what=c("dist", "which"), k=1L, ...) { ## Given a matrix of pairwise distances, ## determine the nearest neighbours ## and return in standard format stopifnot(is.matrix(d)) stopifnot(nrow(d) == ncol(d)) nX <- nrow(d) what <- match.arg(what, several.ok=TRUE) want.dist <- "dist" %in% what want.which <- "which" %in% what ## want.both <- want.dist && want.which if(!missing(k)) { # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } } k <- as.integer(k) kmax <- max(k) nk <- length(k) kmaxcalc <- min(nX, kmax) # number of neighbours that are well-defined ## deal with null cases if(nX == 0) return(as.data.frame(list(dist=matrix(0, nrow=0, ncol=nk), which=matrix(0L, nrow=0, ncol=nk)))[,what]) ## diag(d) <- Inf NND <- NNW <- NULL if(kmax == 1L) { if(want.dist) NND <- apply(d, 1, min) if(want.which) NNW <- apply(d, 1, which.min) } else { kuse <- k[k <= kmaxcalc] nkuse <- length(kuse) kmap <- match(kuse, k) if(want.dist) { NND <- apply(d, 1, orderstats, k=kuse) if(nkuse > 1) NND <- t(NND) if(nk > nkuse) { NNDfull <- matrix(Inf, nrow=nX, ncol=nk) NNDfull[, kmap] <- NND NND <- NNDfull } } if(want.which) { NNW <- apply(d, 1, orderwhich, k=kuse) if(nkuse > 1) NNW <- t(NNW) if(nk > nkuse) { NNWfull <- matrix(NA_integer_, nrow=nX, ncol=nk) NNWfull[, kmap] <- NNW NNW <- NNWfull } } } result <- packupNNdata(NND, NNW, what, k) return(result) } XDtoNN <- function(d, what=c("dist", "which"), iX=NULL, iY=NULL, k=1L, ...) { ## Given a matrix of cross-pairwise distances, ## determine the nearest neighbours ## and return in standard format stopifnot(is.matrix(d)) nX <- nrow(d) nY <- ncol(d) what <- match.arg(what, several.ok=TRUE) want.dist <- "dist" %in% what want.which <- "which" %in% what ## want.both <- want.dist && want.which if(!missing(k)) { # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } } k <- as.integer(k) kmax <- max(k) nk <- length(k) kmaxcalc <- min(nY, kmax) # number of neighbours that are well-defined ## deal with null cases if(nX == 0) return(as.data.frame(list(dist=matrix(0, nrow=0, ncol=nk), which=matrix(0L, nrow=0, ncol=nk)))[,what]) if(nY == 0) return(as.data.frame(list(dist=matrix(Inf, nrow=nX, ncol=nk), which=matrix(NA_integer_, nrow=nX, ncol=nk))[what])) ## exclusion of identical pairs if(is.null(iX) != is.null(iY)) stop("If one of iX, iY is given, then both must be given") exclude <- (!is.null(iX) || !is.null(iY)) if(exclude) { stopifnot(is.integer(iX) && is.integer(iY)) if(length(iX) != nX) stop("length of iX does not match the number of points in X") if(length(iY) != nY) stop("length of iY does not match the number of points in Y") d[cbind(iX, iY)] <- Inf need.dist <- want.which } ## NND <- NNW <- NULL if(kmax == 1L) { if(want.dist || need.dist) NND <- apply(d, 1, min) if(want.which) NNW <- apply(d, 1, which.min) } else { kuse <- k[k <= kmaxcalc] nkuse <- length(kuse) kmap <- match(kuse, k) if(want.dist || need.dist) { NND <- apply(d, 1, orderstats, k=kuse) if(nkuse > 1) NND <- t(NND) if(nk > nkuse) { NNDfull <- matrix(Inf, nrow=nX, ncol=nk) NNDfull[, kmap] <- NND NND <- NNDfull } } if(want.which) { NNW <- apply(d, 1, orderwhich, k=kuse) if(nkuse > 1) NNW <- t(NNW) if(nk > nkuse) { NNWfull <- matrix(NA_integer_, nrow=nX, ncol=nk) NNWfull[, kmap] <- NNW NNW <- NNWfull } } } ## if(want.which && exclude) { if(any(nope <- is.infinite(NND))) NNW[nope] <- NA } ## result <- packupNNdata(NND, NNW, what, k) return(result) } packupNNdata <- function(NND, NNW, what, k) { result <- as.data.frame(list(dist=NND, which=NNW)[what]) colnames(result) <- if(max(k) == 1L) { c(if("dist" %in% what) "dist" else NULL, if("which" %in% what) "which" else NULL) } else { c(if("dist" %in% what) paste0("dist.", k) else NULL, if("which" %in% what) paste0("which.",k) else NULL) } if(ncol(result) == 1L) result <- result[, , drop=TRUE] return(result) } spatstat.geom/R/First.R0000644000176200001440000000061414611065353014463 0ustar liggesusers## spatstat.geom/R/First.R .onLoad <- function(...) { reset.spatstat.options() } .onAttach <- function(libname, pkgname) { vs <- read.dcf(file=system.file("DESCRIPTION", package="spatstat.geom"), fields="Version") vs <- as.character(vs) putSpatstatVariable("SpatstatGeomVersion", vs) packageStartupMessage(paste("spatstat.geom", vs)) return(invisible(NULL)) } spatstat.geom/R/covering.R0000644000176200001440000000214114611065351015203 0ustar liggesusers#' #' covering.R #' #' $Revision: 1.5 $ $Date: 2022/03/26 03:55:47 $ #' covering <- function(W, r, ..., giveup=1000) { W <- as.owin(W) ## compute distance to boundary D <- distmap(W, invert=TRUE, ...) D <- D[W, drop=FALSE] M <- as.owin(D) pixstep <- max(M$xstep, M$ystep) ## very small distances if(r <= pixstep) { warning("r is smaller than the pixel resolution: returning pixel centres", call.=FALSE) xy <- rasterxy.mask(M, drop=TRUE) return(ppp(xy$x, xy$y, window=W, check=FALSE)) } ## find the point of W farthest from the boundary X <- where.max(D) ## build a hexagonal grid through this point ruse <- if(is.convex(W)) r else (r * 2/3) ruse <- max(pixstep, ruse - pixstep) H <- hexgrid(W, ruse, offset=c(X$x, X$y), origin=c(0,0)) if(npoints(H) == 0) H <- X ## this may not suffice if W is irregular for(i in 1:giveup) { DH <- distmap(H, clip=TRUE) if(max(DH) < ruse && npoints(H) > 0) return(H) Hnew <- where.max(DH) H <- superimpose(H, Hnew, W=W) } stop(paste("Failed to converge after adding", giveup, "points"), call.=FALSE) } spatstat.geom/R/minnndist.R0000644000176200001440000000432114611065352015375 0ustar liggesusers## ## minnndist.R ## ## Fast versions of min(nndist(X)), max(nndist(X)) ## ## $Revision: 1.11 $ $Date: 2022/05/21 09:52:11 $ minnndist <- function(X, positive=FALSE, by=NULL) { stopifnot(is.ppp(X)) if(!is.null(by)) { stopifnot(length(by) == npoints(X)) if(positive) { retain <- !duplicated(X) X <- X[retain] by <- by[retain] } nn <- nndist(X, by=by) result <- aggregate(nn, by=list(from=by), min, drop=FALSE)[,-1,drop=FALSE] return(result) } n <- npoints(X) if(n <= 1) return(NA) x <- X$x y <- X$y o <- fave.order(y) big <- sqrt(.Machine$double.xmax) if(positive) { z <- .C(SG_minPnnd2, n = as.integer(n), x = as.double(x[o]), y = as.double(y[o]), as.double(big), result = as.double(numeric(1)), PACKAGE="spatstat.geom") } else { z <- .C(SG_minnnd2, n = as.integer(n), x = as.double(x[o]), y = as.double(y[o]), as.double(big), result = as.double(numeric(1)), PACKAGE="spatstat.geom") } return(sqrt(z$result)) } maxnndist <- function(X, positive=FALSE, by=NULL) { stopifnot(is.ppp(X)) if(!is.null(by)) { stopifnot(length(by) == npoints(X)) if(positive) { retain <- !duplicated(X) X <- X[retain] by <- by[retain] } nn <- nndist(X, by=by) result <- aggregate(nn, by=list(from=by), max, drop=FALSE)[,-1,drop=FALSE] return(result) } n <- npoints(X) if(n <= 1) return(NA) x <- X$x y <- X$y o <- fave.order(y) big <- sqrt(.Machine$double.xmax) if(positive) { z <- .C(SG_maxPnnd2, n = as.integer(n), x = as.double(x[o]), y = as.double(y[o]), as.double(big), result = as.double(numeric(1)), PACKAGE="spatstat.geom") } else { z <- .C(SG_maxnnd2, n = as.integer(n), x = as.double(x[o]), y = as.double(y[o]), as.double(big), result = as.double(numeric(1)), PACKAGE="spatstat.geom") } return(sqrt(z$result)) } avenndist <- function(X) mean(nndist(unique(X))) spatstat.geom/R/randomseg.R0000644000176200001440000000201214611065352015344 0ustar liggesusers# # randomseg.R # # $Revision: 1.18 $ $Date: 2024/02/04 08:04:51 $ # rlinegrid <- function(angle=45, spacing=0.1, win=owin()) { win <- as.owin(win) # determine circumcircle width <- diff(win$xrange) height <- diff(win$yrange) rmax <- sqrt(width^2 + height^2)/2 xmid <- mean(win$xrange) ymid <- mean(win$yrange) # generate randomly-displaced grid of lines through circumcircle u <- runif(1, min=0, max=spacing) - rmax if(u >= rmax) return(psp(numeric(0), numeric(0), numeric(0), numeric(0), window=win, check=FALSE)) p <- seq(from=u, to=rmax, by=spacing) # compute intersection points with circle q <- sqrt(rmax^2 - p^2) theta <- pi * ((angle - 90)/180) co <- cos(theta) si <- sin(theta) X <- psp(x0= xmid + p * co + q * si, y0= ymid + p * si - q * co, x1= xmid + p * co - q * si, y1= ymid + p * si + q * co, window=owinInternalRect(xmid+c(-1,1)*rmax, ymid+c(-1,1)*rmax), check=FALSE) # clip to window X <- X[win] return(X) } spatstat.geom/R/weights.R0000644000176200001440000002345114611065353015052 0ustar liggesusers# # weights.S # # Utilities for computing quadrature weights # # $Revision: 4.40 $ $Date: 2020/01/10 06:54:23 $ # # # Main functions: # gridweights() Divide the window frame into a regular nx * ny # grid of rectangular tiles. Given an arbitrary # pattern of (data + dummy) points derive the # 'counting weights'. # # dirichletWeights() Compute the areas of the tiles of the # Dirichlet tessellation generated by the # given pattern of (data+dummy) points, # restricted to the window. # # Auxiliary functions: # # countingweights() compute the counting weights # for a GENERIC tiling scheme and an arbitrary # pattern of (data + dummy) points, # given the tile areas and the information # that point number k belongs to tile number id[k]. # # # gridindex() Divide the window frame into a regular nx * ny # grid of rectangular tiles. # Compute tile membership for arbitrary x,y. # # grid1index() 1-dimensional analogue of gridindex() # # #------------------------------------------------------------------- countingweights <- function(id, areas, check=TRUE) { # # id: cell indices of n points # (length n, values in 1:k) # # areas: areas of k cells # (length k) # id <- as.integer(id) fid <- factor(id, levels=seq_along(areas)) counts <- table(fid) w <- areas[id] / counts[id] # ensures denominator > 0 w <- as.vector(w) # # that's it; but check for funny business # if(check) { zerocount <- (counts == 0) zeroarea <- (areas == 0) if(any(!zeroarea & zerocount)) { lostfrac <- 1 - sum(w)/sum(areas) lostpc <- round(100 * lostfrac, 1) if(lostpc >= 1) warning(paste("some tiles with positive area", "do not contain any quadrature points:", "relative error =", paste0(lostpc, "%"))) } if(any(!zerocount & zeroarea)) { warning("Some tiles with zero area contain quadrature points") warning("Some weights are zero") attr(w, "zeroes") <- zeroarea[id] } } # names(w) <- NULL return(w) } gridindex <- function(x, y, xrange, yrange, nx, ny) { # # The box with dimensions xrange, yrange is divided # into nx * ny cells. # # For each point (x[i], y[i]) compute the index (ix, iy) # of the cell containing the point. # ix <- grid1index(x, xrange, nx) iy <- grid1index(y, yrange, ny) # return(list(ix=ix, iy=iy, index=as.integer((iy-1) * nx + ix))) } grid1index <- function(x, xrange, nx) { i <- ceiling( nx * (x - xrange[1])/diff(xrange)) i <- pmax.int(1, i) i <- pmin.int(i, nx) i } gridweights <- function(X, ntile=NULL, ..., window=NULL, verbose=FALSE, npix=NULL, areas=NULL) { # # Compute counting weights based on a regular tessellation of the # window frame into ntile[1] * ntile[2] rectangular tiles. # # Arguments X and (optionally) 'window' are interpreted as a # point pattern. # # The window frame is divided into a regular ntile[1] * ntile[2] grid # of rectangular tiles. The counting weights based on this tessellation # are computed for the points (x, y) of the pattern. # # 'npix' determines the dimensions of the pixel raster used to # approximate tile areas. X <- as.ppp(X, window) x <- X$x y <- X$y win <- X$window # determine number of tiles if(is.null(ntile)) ntile <- default.ntile(X) if(length(ntile) == 1) ntile <- rep.int(ntile, 2) nx <- ntile[1] ny <- ntile[2] if(verbose) cat(paste("grid weights for a", nx, "x", ny, "grid of tiles\n")) ## determine pixel resolution in case it is required if(!is.null(npix)) { npix <- ensure2vector(npix) } else { npix <- pmax(rev(spatstat.options("npixel")), c(nx, ny)) if(is.mask(win)) npix <- pmax(npix, rev(dim(win))) } if(is.null(areas)) { # compute tile areas switch(win$type, rectangle = { nxy <- nx * ny tilearea <- area(win)/nxy areas <- rep.int(tilearea, nxy) zeroareas <- rep(FALSE, nxy) }, polygonal = { areamat <- polytileareaEngine(win, win$xrange, win$yrange, nx, ny) ## convert from 'im' to 'gridindex' ordering areas <- as.vector(t(areamat)) zeroareas <- (areas == 0) if(verbose) splat("Split polygonal window of area", area(win), "into", nx, "x", ny, "grid of tiles", "of total area", sum(areas)) }, mask = { win <- as.mask(win, dimyx=rev(npix)) if(verbose) splat("Converting mask dimensions to", npix[1], "x", npix[2], "pixels") ## extract pixel coordinates inside window rxy <- rasterxy.mask(win, drop=TRUE) xx <- rxy$x yy <- rxy$y ## classify all pixels into tiles pixelid <- gridindex(xx, yy, win$xrange, win$yrange, nx, ny)$index pixelid <- factor(pixelid, levels=seq_len(nx * ny)) ## compute digital areas of tiles tilepixels <- as.vector(table(pixelid)) pixelarea <- win$xstep * win$ystep areas <- tilepixels * pixelarea zeroareas <- (tilepixels == 0) } ) } else zeroareas <- (areas == 0) id <- gridindex(x, y, win$xrange, win$yrange, nx, ny)$index if(win$type != "rectangle" && any(uhoh <- zeroareas[id])) { # this can happen: the tile has digital area zero # but contains a data/dummy point slivers <- unique(id[uhoh]) switch(win$type, mask = { offence <- "digital area zero" epsa <- pixelarea/2 }, polygonal = { offence <- "very small area" epsa <- min(areas[!zeroareas])/10 }) areas[slivers] <- epsa nsliver <- length(slivers) extraarea <- nsliver * epsa extrafrac <- extraarea/area(win) if(verbose || extrafrac > 0.01) { splat(nsliver, ngettext(nsliver, "tile", "tiles"), "of", offence, ngettext(nsliver, "was", "were"), "given nominal area", signif(epsa, 3), "increasing the total area by", signif(extraarea, 5), "square units or", paste0(round(100 * extrafrac, 1), "% of total area")) if(extrafrac > 0.01) warning(paste("Repairing tiles with", offence, "caused a", paste0(round(100 * extrafrac), "%"), "change in total area"), call.=FALSE) } } # compute counting weights w <- countingweights(id, areas) # attach information about weight construction parameters attr(w, "weight.parameters") <- list(method="grid", ntile=ntile, npix=npix, areas=areas) return(w) } # dirichlet.weights <- function(...) { # .Deprecated("dirichletWeights", package="spatstat") # dirichletWeights(...) # } dirichletWeights <- function(X, window = NULL, exact=TRUE, ...) { #' #' Compute weights based on Dirichlet tessellation of the window #' induced by the point pattern X. #' The weights are just the tile areas. #' #' NOTE: X should contain both data and dummy points, #' if you need these weights for the B-T-B method. #' #' Arguments X and (optionally) 'window' are interpreted as a #' point pattern. #' #' If the window is a rectangle, we invoke Rolf Turner's "deldir" #' package to compute the areas of the tiles of the Dirichlet #' tessellation of the window frame induced by the points. #' [NOTE: the functionality of deldir to create dummy points #' is NOT used. ] #' if exact=TRUE compute the exact areas, using "deldir" #' if exact=FALSE compute the digital areas using exactdt() #' #' If the window is a mask, we compute the digital area of #' each tile of the Dirichlet tessellation by counting pixels. #' #' #' X <- as.ppp(X, window) if(!exact && is.polygonal(Window(X))) Window(X) <- as.mask(Window(X)) #' compute tile areas w <- dirichletAreas(X) #' zero areas can occur due to discretisation or weird geometry zeroes <- (w == 0) if(any(zeroes)) { #' compute weights for subset nX <- npoints(X) Xnew <- X[!zeroes] wnew <- dirichletAreas(Xnew) w <- numeric(nX) w[!zeroes] <- wnew #' map deleted points to nearest retained point jj <- nncross(X[zeroes], Xnew, what="which") #' map retained points to themselves ii <- Xseq <- seq_len(nX) ii[zeroes] <- (ii[!zeroes])[jj] #' redistribute weights nshare <- table(factor(ii, levels=Xseq)) w <- w[ii]/nshare[ii] } #' attach information about weight construction parameters attr(w, "weight.parameters") <- list(method="dirichlet", exact=exact) return(w) } default.ntile <- function(X) { # default number of tiles (n x n) for tile weights # when data and dummy points are X X <- as.ppp(X) guess.ngrid <- 10 * floor(sqrt(X$n)/10) max(5, guess.ngrid/2) } spatstat.geom/R/edges2triangles.R0000644000176200001440000000771114611065351016461 0ustar liggesusers# # edges2triangles.R # # $Revision: 1.18 $ $Date: 2022/05/21 09:52:11 $ # edges2triangles <- function(iedge, jedge, nvert=max(iedge, jedge), ..., check=TRUE, friendly=rep(TRUE, nvert)) { usefriends <- !missing(friendly) if(check) { stopifnot(length(iedge) == length(jedge)) stopifnot(all(iedge > 0)) stopifnot(all(jedge > 0)) if(!missing(nvert)) { stopifnot(all(iedge <= nvert)) stopifnot(all(jedge <= nvert)) } if(usefriends) { stopifnot(is.logical(friendly)) stopifnot(length(friendly) == nvert) usefriends <- !all(friendly) } } # zero length data, or not enough to make triangles if(length(iedge) < 3) return(matrix(integer(0), nrow=0, ncol=3, dimnames=list(NULL, c("i", "j", "k")))) # sort in increasing order of 'iedge' oi <- fave.order(iedge) iedge <- iedge[oi] jedge <- jedge[oi] # call C storage.mode(nvert) <- storage.mode(iedge) <- storage.mode(jedge) <- "integer" if(usefriends) { fr <- as.logical(friendly) storage.mode(fr) <- "integer" zz <- .Call(SG_trioxgraph, nv=nvert, iedge=iedge, jedge=jedge, friendly=fr, PACKAGE="spatstat.geom") } else if(spatstat.options("fast.trigraph")) { zz <- .Call(SG_triograph, nv=nvert, iedge=iedge, jedge=jedge, PACKAGE="spatstat.geom") } else { #' testing purposes only zz <- .Call(SG_trigraph, nv=nvert, iedge=iedge, jedge=jedge, PACKAGE="spatstat.geom") } mat <- as.matrix(as.data.frame(zz, col.names=c("i", "j", "k"))) return(mat) } # compute triangle diameters as well trianglediameters <- function(iedge, jedge, edgelength, ..., nvert=max(iedge, jedge), dmax=Inf, check=TRUE) { if(check) { stopifnot(length(iedge) == length(jedge)) stopifnot(length(iedge) == length(edgelength)) stopifnot(all(iedge > 0)) stopifnot(all(jedge > 0)) if(!missing(nvert)) { stopifnot(all(iedge <= nvert)) stopifnot(all(jedge <= nvert)) } if(is.finite(dmax)) check.1.real(dmax) } # zero length data if(length(iedge) == 0 || dmax < 0) return(data.frame(i=integer(0), j=integer(0), k=integer(0), diam=numeric(0))) # call C storage.mode(nvert) <- storage.mode(iedge) <- storage.mode(jedge) <- "integer" storage.mode(edgelength) <- "double" if(is.infinite(dmax)) { zz <- .Call(SG_triDgraph, nv=nvert, iedge=iedge, jedge=jedge, edgelength=edgelength, PACKAGE="spatstat.geom") } else { storage.mode(dmax) <- "double" zz <- .Call(SG_triDRgraph, nv=nvert, iedge=iedge, jedge=jedge, edgelength=edgelength, dmax=dmax, PACKAGE="spatstat.geom") } df <- as.data.frame(zz) colnames(df) <- c("i", "j", "k", "diam") return(df) } closetriples <- function(X, rmax) { a <- closepairs(X, rmax, what="ijd", twice=FALSE, neat=FALSE) tri <- trianglediameters(a$i, a$j, a$d, nvert=npoints(X), dmax=rmax) return(tri) } # extract 'vees', i.e. triples (i, j, k) where i ~ j and i ~ k edges2vees <- function(iedge, jedge, nvert=max(iedge, jedge), ..., check=TRUE) { if(check) { stopifnot(length(iedge) == length(jedge)) stopifnot(all(iedge > 0)) stopifnot(all(jedge > 0)) if(!missing(nvert)) { stopifnot(all(iedge <= nvert)) stopifnot(all(jedge <= nvert)) } } # zero length data, or not enough to make vees if(length(iedge) < 2) return(data.frame(i=numeric(0), j=numeric(0), k=numeric(0))) ## call vees <- .Call(SG_graphVees, nv = nvert, iedge = iedge, jedge = jedge, PACKAGE="spatstat.geom") names(vees) <- c("i", "j", "k") vees <- as.data.frame(vees) return(vees) } spatstat.geom/R/circarcs.R0000644000176200001440000000717714611065351015176 0ustar liggesusers#' #' circarcs.R #' #' Circular Arcs #' #' An interval on the circle is specified by [left, right] #' meaning the arc starting at 'left' going anticlockwise until 'right'. #' Here 'left' and 'right' are angles in radians (mod 2*pi) #' from the positive x-axis. #' #' $Revision: 1.5 $ $Date: 2019/12/06 06:15:29 $ check.arc <- function(arc, fatal=TRUE) { if(is.numeric(arc) && length(arc) == 2) return(TRUE) if(fatal) stop("arc should be a numeric vector of length 2") return(FALSE) } inside.arc <- function(theta, arc) { check.arc(arc) arc <- arc %% (2*pi) theta <- theta %% (2*pi) if(arc[1] <= arc[2]) { #' arc does not cross the positive x-axis result <- (arc[1] <= theta) & (theta <= arc[2]) } else { #' arc crosses the positive x-axis result <- (arc[1] <= theta) | (theta <= arc[2]) } return(result) } circunion <- function(arcs) { stopifnot(is.list(arcs)) nothing <- list() everything <- list(c(0, 2*pi)) if(length(arcs) == 0) return(nothing) lapply(arcs, check.arc) #' extract all endpoints allends <- unlist(arcs) allends <- sortunique(as.numeric(allends) %% (2*pi)) #' compute midpoints between each successive pair of endpoints (mod 2pi) midpts <- allends + diff(c(allends, allends[1] + 2*pi))/2 #' determine which midpoints lie inside one of the arcs midinside <- Reduce("|", lapply(arcs, inside.arc, theta=midpts)) zeroinside <- any(sapply(arcs, inside.arc, theta=0)) if(!any(midinside) && !zeroinside) return(nothing) if(all(midinside) && zeroinside) return(everything) result <- nothing if(zeroinside) { #' First deal with the connected component containing 0 #' Scan clockwise from 2*pi for left endpoint of interval n <- length(midinside) ileft <- (max(which(!midinside)) %% n) + 1L aleft <- allends[ileft] #' then anticlockwise for right endpoint iright <- min(which(!midinside)) aright <- allends[iright] #' save this interval result <- append(result, list(c(aleft, aright))) #' remove data from consideration seqn <- seq_len(n) retain <- seqn > iright & seqn < (ileft-1L) midinside <- midinside[retain] allends <- allends[retain] } #' Now scan anticlockwise for first midpoint that is inside the union while(any(midinside)) { ileft <- min(which(midinside)) toright <- (seq_along(midinside) > ileft) iright <- min(c(length(allends), which(!midinside & toright))) aleft <- allends[ileft] aright <- allends[iright] #' save this interval result <- append(result, list(c(aleft, aright))) #' throw away points that are not endpoints of the union midinside <- midinside[seq_along(midinside) > iright] allends <- allends[seq_along(allends) > iright] } return(result) } # plotarc <- function(arc, ..., add=TRUE, lwd=3, rad=1){ # if(!add || is.null(dev.list())) # plot(disc(), main="") # if(diff(arc) < 0) # arc[2] <- arc[2] + 2*pi # ang <- seq(arc[1], arc[2], by=0.01) # lines(rad * cos(ang), rad * sin(ang), ..., lwd=lwd) # } # # plotarcs <- function(arcs, ..., rad=1, jitter=FALSE, add=FALSE) { # if(length(rad) == 1) rad <- rep(rad, length(arcs)) # if(jitter) rad <- rad * seq(0.9, 1.05, length=length(rad)) # rad <- as.list(rad) # if(!add) plot(disc(), main="") # mapply(plotarc, arc=arcs,rad=rad, MoreArgs=list(...)) # invisible(NULL) # } # # runifarc <- function(n=1, maxlen=pi) { # replicate(n, runif(1, 0, 2*pi) + c(0, runif(1, 0, maxlen)), simplify=FALSE) # } # # tryit <- function(n=5, maxlen=pi) { # a <- runifarc(n, maxlen=maxlen) # plotarcs(circunion(a), col=3, jitter=FALSE, lwd=6) # plotarcs(a, jitter=TRUE, lwd=2, add=TRUE) # } spatstat.geom/R/uniquemap.ppp.R0000644000176200001440000000470414636754420016211 0ustar liggesusers#' #' uniquemap.ppp.R #' #' Methods for 'uniquemap' for classes ppp, lpp, ppx #' #' Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2019 #' Licence: GNU Public Licence >= 2 #' #' $Revision: 1.1 $ $Date: 2024/06/26 08:26:30 $ uniquemap.ppp <- function(x) { n <- npoints(x) seqn <- seq_len(n) if(n <= 1) return(seqn) marx <- marks(x) switch(markformat(marx), none = { useC <- TRUE }, vector = { #' convert to integers if possible if(is.integer(marx) || is.factor(marx)) { marx <- as.integer(marx) useC <- TRUE } else { um <- unique(marx) if(length(um) <= 2^30) { marx <- match(marx, um) useC <- TRUE } else { useC <- FALSE } } }, { useC <- FALSE }) if(!useC) { #' first find duplicated spatial coordinates u <- uniquemap(unmark(x)) #' add marks df <- cbind(data.frame(ind=seqn, uni=u), as.data.frame(marx)) bb <- split(df, factor(u)) #' consider each set of duplicated locations for(b in bb) { #' find unique rows of marks, as a list mrows <- lapply(seq_len(nrow(b)), function(i) b[i, -(1:2)]) um <- unique(mrows) #' match other rows to them ma <- match(mrows, um) #' map to original index u[b$ind] <- b$ind[ma] } return(u) } #' unmarked or integer/factor marked xx <- x$x yy <- x$y o <- order(xx, seqn) if(is.null(marx)) { umap <- .C(SG_uniqmapxy, n=as.integer(n), x=as.double(xx[o]), y=as.double(yy[o]), uniqmap=as.integer(integer(n)), PACKAGE="spatstat.geom")$uniqmap } else { #' marks are (converted to) integers umap <- .C(SG_uniqmap2M, n=as.integer(n), x=as.double(xx[o]), y=as.double(yy[o]), marks=as.integer(marx[o]), uniqmap=as.integer(integer(n)), PACKAGE="spatstat.geom")$uniqmap } nodup <- (umap == 0) umap[nodup] <- which(nodup) result <- integer(n) result[o] <- o[umap] return(result) } uniquemap.lpp <- function(x) { n <- npoints(x) if(n <= 1 || !anyDuplicated(as.ppp(x))) return(seq_len(n)) result <- uniquemap(as.data.frame(x)) return(result) } uniquemap.ppx <- function(x) { uniquemap(as.data.frame(x)) } spatstat.geom/R/fourierbasis.R0000644000176200001440000000156714611065352016100 0ustar liggesusers#' fourierbasis.R #' $Revision: 1.4 $ $Date: 2017/11/04 04:10:32 $ fourierbasis <- function(x, k, win = boxx(rep(list(0:1), ncol(k)))) { x <- as.matrix(x) k <- as.matrix(k) if (nrow(k) == 0 | nrow(x) == 0) return(complex()) d <- ncol(x) if (ncol(k) != d) stop("Arguments x and k must have the same number of columns.") win <- as.boxx(win) boxlengths <- as.numeric(win$ranges[2L, ] - win$ranges[1L, ]) if (length(boxlengths) != d) stop("The box dimension differs from the number of columns in x and k") return(fourierbasisraw(x, k, boxlengths)) } fourierbasisraw <- function(x, k, boxlengths) { two_pi_i <- 2 * pi * (0+1i) rslt <- outer(k[, 1L], x[, 1L]/boxlengths[1L]) d <- ncol(x) if (d > 1) { for (i in 2:d) { rslt <- rslt + outer(k[, i], x[, i]/boxlengths[i]) } } return(exp(two_pi_i * rslt)/sqrt(prod(boxlengths))) } spatstat.geom/R/plot.anylist.R0000644000176200001440000006441014722270275016044 0ustar liggesusers## ## plot.anylist.R ## ## Plotting functions for 'solist', 'anylist', 'imlist' ## and legacy class 'listof' ## ## $Revision: 1.39 $ $Date: 2024/11/28 01:15:40 $ ## plot.anylist <- plot.solist <- plot.listof <- local({ ## auxiliary functions classes.with.do.plot <- c("im", "ppp", "psp", "msr", "layered", "tess") classes.with.multiplot <- c("ppp", "lpp", "msr", "tess", "leverage.ppm", "influence.ppm") has.multiplot <- function(x) { inherits(x, classes.with.multiplot) || (is.function(x) && "multiplot" %in% names(formals(x))) } extraplot <- function(nnn, x, ..., add=FALSE, extrargs=list(), panel.args=NULL, plotcommand="plot") { argh <- list(...) if(has.multiplot(x) && identical(plotcommand,"plot")) argh <- c(argh, list(multiplot=FALSE)) if(!is.null(panel.args)) { xtra <- if(is.function(panel.args)) panel.args(nnn) else panel.args if(!is.list(xtra)) stop(paste0("panel.args", if(is.function(panel.args)) "(i)" else "", " should be a list")) argh <- resolve.defaults(xtra, argh) } if(length(extrargs) > 0) argh <- resolve.defaults(argh, extrargs) ## some plot commands don't recognise 'add' if(add) argh <- append(argh, list(add=TRUE)) do.call(plotcommand, append(list(x=x), argh)) } exec.or.plot <- function(cmd, i, xi, ..., extrargs=list(), add=FALSE) { if(is.null(cmd)) return(NULL) argh <- resolve.defaults(list(...), extrargs, ## some plot commands don't recognise 'add' if(add) list(add=TRUE) else NULL, if(has.multiplot(cmd)) list(multiplot=FALSE) else NULL) if(is.function(cmd)) { force(xi) do.call(cmd, resolve.defaults(list(i, quote(xi)), argh)) } else { do.call(plot, resolve.defaults(list(cmd), argh)) } } exec.or.plotshift <- function(cmd, i, xi, ..., vec=vec, extrargs=list(), add=FALSE) { if(is.null(cmd)) return(NULL) argh <- resolve.defaults(list(...), extrargs, ## some plot commands don't recognise 'add' if(add) list(add=TRUE) else NULL, if(has.multiplot(cmd)) list(multiplot=FALSE) else NULL) if(is.function(cmd)) { force(xi) do.call(cmd, resolve.defaults(list(i, quote(xi)), argh)) } else { cmd <- shift(cmd, vec) do.call(plot, resolve.defaults(list(quote(cmd)), argh)) } } ## bounding box, including ribbon for images, legend for point patterns getplotbox <- function(x, ..., do.plot, plotcommand="plot", multiplot) { if(inherits(x, classes.with.do.plot)) { if(identical(plotcommand, "plot")) { y <- if(has.multiplot(x)) plot(x, ..., multiplot=FALSE, do.plot=FALSE) else plot(x, ..., do.plot=FALSE) return(as.owin(y)) } else if(identical(plotcommand, "contour")) { y <- contour(x, ..., do.plot=FALSE) return(as.owin(y)) } else { plc <- plotcommand if(is.character(plc)) plc <- get(plc) if(!is.function(plc)) stop("Unrecognised plot function") if("do.plot" %in% names(args(plc))) { if(has.multiplot(plc)) { y <- do.call(plc, list(x=x, ..., multiplot=FALSE, do.plot=FALSE)) } else { y <- do.call(plc, list(x=x, ..., do.plot=FALSE)) } return(as.owin(y)) } } } return(try(as.rectangle(x), silent=TRUE)) } # calculate bounding boxes for each panel using intended arguments! getPlotBoxes <- function(xlist, ..., panel.args=NULL, extrargs=list()) { userargs <- list(...) n <- length(xlist) result <- vector(length=n, mode="list") for(i in seq_len(n)) { pai <- if(is.function(panel.args)) panel.args(i) else list() argh <- resolve.defaults(pai, userargs, extrargs) xxi <- xlist[[i]] result[[i]] <- do.call(getplotbox, append(list(x=quote(xxi)), argh)) } return(result) } is.shiftable <- function(x) { if(is.null(x)) return(TRUE) if(is.function(x)) return(FALSE) y <- try(as.rectangle(x), silent=TRUE) return(!inherits(y, "try-error")) } maxassigned <- function(i, values) max(-1, values[i[i > 0]]) plotadornment <- function(adorn, adorn.args, ...) { aname <- deparse(substitute(adorn)) if(is.null(adorn)) { z <- NULL } else if(is.function(adorn)) { z <- do.call(adorn, resolve.defaults(adorn.args, list(...))) } else if(inherits(adorn, c("colourmap", "symbolmap"))) { z <- do.call(plot, resolve.defaults(list(x=adorn), adorn.args, list(...))) } else warning("Unrecognised format for", sQuote(aname)) return(z) } plot.anylist <- function(x, ..., main, arrange=TRUE, nrows=NULL, ncols=NULL, main.panel=NULL, mar.panel=c(2,1,1,2), hsep = 0, vsep = 0, panel.begin=NULL, panel.end=NULL, panel.args=NULL, panel.begin.args=NULL, panel.end.args=NULL, panel.vpad = 0.2, plotcommand="plot", adorn.left=NULL, adorn.right=NULL, adorn.top=NULL, adorn.bottom=NULL, adorn.size=0.2, adorn.args=list(), equal.scales=FALSE, halign=FALSE, valign=FALSE ) { xname <- short.deparse(substitute(x)) ## recursively expand entries which are 'anylist' etc while(any(sapply(x, inherits, what="anylist"))) x <- as.solist(expandSpecialLists(x, "anylist"), demote=TRUE) isSo <- inherits(x, "solist") isIm <- inherits(x, "imlist") || (isSo && all(unlist(lapply(x, is.im)))) ## `boomerang despatch' cl <- match.call() if(missing(plotcommand) && isIm) { cl[[1]] <- as.name("image.imlist") parenv <- sys.parent() return(invisible(eval(cl, envir=parenv))) } ## determine whether 'fv' objects are present if(isSo) { allfv <- somefv <- FALSE } else { isfv <- unlist(lapply(x, is.fv)) allfv <- all(isfv) somefv <- any(isfv) if(somefv && !requireNamespace("spatstat.explore")) stop(paste("Package 'spatstat.explore' is required", "for plotting objects of class 'fv'"), call.=FALSE) } ## panel margins if(!missing(mar.panel)) { nm <- length(mar.panel) if(nm == 1) mar.panel <- rep(mar.panel, 4) else if(nm == 2) mar.panel <- rep(mar.panel, 2) else if(nm != 4) stop("mar.panel should have length 1, 2 or 4") } else if(somefv) { ## change default mar.panel <- 0.25+c(4,4,2,2) } n <- length(x) names(x) <- good.names(names(x), "Component_", 1:n) if(is.null(main.panel)) main.panel <- names(x) else { if(!is.expression(main.panel)) main.panel <- as.character(main.panel) nmp <- length(main.panel) if(nmp == 1) main.panel <- rep.int(main.panel, n) else if(nmp != n) stop("Incorrect length for main.panel") } if(allfv && equal.scales) { ## all entries are 'fv' objects: determine their plot limits fvlims <- lapply(x, plot, ..., limitsonly=TRUE) ## establish common x,y limits for all panels xlim <- range(unlist(lapply(fvlims, getElement, name="xlim"))) ylim <- range(unlist(lapply(fvlims, getElement, name="ylim"))) extrargs <- list(xlim=xlim, ylim=ylim) } else extrargs <- list() extrargs.begin <- resolve.defaults(panel.begin.args, extrargs) extrargs.end <- resolve.defaults(panel.end.args, extrargs) ## adornments adornments <- list(adorn.left = adorn.left, adorn.right = adorn.right, adorn.top = adorn.top, adorn.bottom = adorn.bottom) adornments <- adornments[!sapply(adornments, is.null)] nadorn <- length(adornments) adorable <- all(sapply(adornments, inherits, what=c("symbolmap", "colourmap"))) ## "texturemap" not yet supported by plan.legend.layout if(!arrange) { ## sequence of plots result <- vector(mode="list", length=n) for(i in 1:n) { xi <- x[[i]] exec.or.plot(panel.begin, i, xi, main=main.panel[i], extrargs=extrargs.begin) result[[i]] <- extraplot(i, xi, ..., add=!is.null(panel.begin), main=main.panel[i], panel.args=panel.args, extrargs=extrargs, plotcommand=plotcommand) %orifnull% list() exec.or.plot(panel.end, i, xi, add=TRUE, extrargs=extrargs.end) } if(nadorn > 0) warning(paste(ngettext(nadorn, "Argument", "Arguments"), commasep(sQuote(names(adornments))), ngettext(nadorn, "was", "were"), "ignored because arrange=FALSE"), call.=FALSE) return(invisible(result)) } ## ARRAY of plots ## decide whether to plot a main header main <- if(!missing(main) && !is.null(main)) main else xname if(!is.character(main)) { ## main title could be an expression nlines <- 1 banner <- TRUE } else { ## main title is character string/vector, possibly "" banner <- any(nzchar(main)) if(length(main) > 1) main <- paste(main, collapse="\n") nlines <- length(unlist(strsplit(main, "\n"))) } ## determine arrangement of plots ## arrange like mfrow(nrows, ncols) plus a banner at the top if(is.null(nrows) && is.null(ncols)) { nrows <- as.integer(floor(sqrt(n))) ncols <- as.integer(ceiling(n/nrows)) } else if(!is.null(nrows) && is.null(ncols)) ncols <- as.integer(ceiling(n/nrows)) else if(is.null(nrows) && !is.null(ncols)) nrows <- as.integer(ceiling(n/ncols)) else stopifnot(nrows * ncols >= length(x)) nblank <- ncols * nrows - n if(allfv || list(plotcommand) %in% list("persp", persp)) { ## Function plots do not have physical 'size' sizes.known <- FALSE } else { ## Determine dimensions of objects ## (including space for colour ribbons, if they are images) boxes <- getPlotBoxes(x, ..., plotcommand=plotcommand, panel.args=panel.args, extrargs=extrargs) sizes.known <- !any(sapply(boxes, inherits, what="try-error")) sizes.known <- sizes.known && (nadorn == 0 || adorable) if(sizes.known) { extrargs <- resolve.defaults(extrargs, list(claim.title.space=TRUE)) boxes <- getPlotBoxes(x, ..., plotcommand=plotcommand, panel.args=panel.args, extrargs=extrargs) } if(equal.scales && !sizes.known) { warning("Ignored equal.scales=TRUE; scales could not be determined") equal.scales <- FALSE } } if(sizes.known) { ## determine size of each panel if(equal.scales) { ## do not rescale panels scaledboxes <- boxes } else { ## rescale panels sides <- lapply(boxes, sidelengths) bwidths <- unlist(lapply(sides, "[", 1)) bheights <- unlist(lapply(sides, "[", 2)) ## Force equal heights, unless there is only one column scales <- if(ncols > 1) 1/bheights else 1/bwidths if(all(is.finite(scales))) { scaledboxes <- vector(mode="list", length=n) for(i in 1:n) scaledboxes[[i]] <- scalardilate(boxes[[i]], scales[i]) } else { #' uh-oh equal.scales <- sizes.known <- FALSE scaledboxes <- boxes } } } ## determine whether to display all objects in one enormous plot ## Precondition is that everything has a spatial bounding box single.plot <- equal.scales && sizes.known if(equal.scales && !single.plot && !allfv) warning("equal.scales=TRUE ignored ", "because bounding boxes ", "could not be determined", call.=FALSE) ## enforce alignment by expanding boxes if(halign) { if(!equal.scales) warning("halign=TRUE ignored because equal.scales=FALSE") ## x coordinates align in each column xr <- range(sapply(scaledboxes, getElement, name="xrange")) scaledboxes <- lapply(scaledboxes, "[[<-", i="xrange", value=xr) } if(valign) { if(!equal.scales) warning("valign=TRUE ignored because equal.scales=FALSE") ## y coordinates align in each column yr <- range(sapply(scaledboxes, getElement, name="yrange")) scaledboxes <- lapply(scaledboxes, "[[<-", i="yrange", value=yr) } ## set up layout mat <- matrix(c(seq_len(n), integer(nblank)), byrow=TRUE, ncol=ncols, nrow=nrows) if(sizes.known) { boxsides <- lapply(scaledboxes, sidelengths) xwidths <- sapply(boxsides, "[", i=1) xheights <- sapply(boxsides, "[", i=2) heights <- apply(mat, 1, maxassigned, values=xheights) widths <- apply(mat, 2, maxassigned, values=xwidths) } else { heights <- rep.int(1, nrows) widths <- rep.int(1, ncols) } #' negative heights/widths arise if a row/column is not used. meanheight <- mean(heights[heights > 0]) meanwidth <- mean(widths[heights > 0]) heights[heights <= 0] <- meanheight widths[widths <= 0] <- meanwidth nall <- n ## if(single.plot) { ## ......... create a single plot .................. ## determine sizes ht <- max(heights) wd <- max(widths) marpar <- mar.panel * c(ht, wd, ht, wd)/6 vsep <- vsep * ht/6 hsep <- hsep * wd/6 mainheight <- any(nzchar(main.panel)) * ht/5 ewidths <- marpar[2] + widths + marpar[4] eheights <- marpar[1] + heights + marpar[3] + mainheight ## create box delimiting all panels Width <- sum(ewidths) + hsep * (length(ewidths) - 1) Height <- sum(eheights) + vsep * (length(eheights) - 1) bigbox <- owinInternalRect(c(0, Width), c(0, Height)) ## bottom left corner of each panel ox <- marpar[2] + cumsum(c(0, ewidths + hsep))[1:ncols] oy <- marpar[1] + cumsum(c(0, rev(eheights) + vsep))[nrows:1] panelorigin <- as.matrix(expand.grid(x=ox, y=oy)) ## add space for adornments (colour maps or symbol maps) if(nadorn > 0) { ## box containing spatial objects but excluding annotations rx <- c(min(ox), max(ox) + widths[length(widths)]) ry <- c(min(oy), max(oy) + heights[length(heights)]) actionbox <- owinInternalRect(rx, ry) ## calculate extensions sidestrings <- sub("adorn.", "", names(adornments)) sideplans <- mapply(plan.legend.layout, MoreArgs=list(B=actionbox), side=sidestrings, map=unname(adornments), SIMPLIFY=FALSE) ## extract box for each adornment sideboxes <- lapply(sideplans, getElement, name="b") ## update bigbox to contain them all coveringboxes <- lapply(sideplans, getElement, name="A") bigbox <- do.call(boundingbox, append(list(bigbox), coveringboxes)) } ## initialise, with banner cex <- resolve.1.default(list(cex.title=1.5), list(...))/par('cex.main') plot(bigbox, type="n", main=main, cex.main=cex) ## plot individual objects result <- vector(mode="list", length=n) for(i in 1:n) { ## determine shift vector that moves bottom left corner of spatial box ## to bottom left corner of target area on plot device vec <- panelorigin[i,] - with(scaledboxes[[i]], c(xrange[1], yrange[1])) ## shift panel contents xi <- x[[i]] xishift <- shift(xi, vec) ## let rip if(!is.null(panel.begin)) exec.or.plotshift(panel.begin, i, xishift, add=TRUE, main=main.panel[i], show.all=TRUE, extrargs=extrargs.begin, vec=vec) result[[i]] <- extraplot(i, xishift, ..., add=TRUE, show.all=is.null(panel.begin), main=main.panel[i], extrargs=extrargs, panel.args=panel.args, plotcommand=plotcommand) %orifnull% list() exec.or.plotshift(panel.end, i, xishift, add=TRUE, extrargs=extrargs.end, vec=vec) } ## add adornments if any for(i in seq_len(nadorn)) { bi <- sideboxes[[i]] do.call(plot, resolve.defaults(list(x=adornments[[i]]), list(...), list(add=TRUE, xlim=bi$xrange, ylim=bi$yrange, side=sidestrings[i]), adorn.args)) } return(invisible(result)) } ## ................. multiple logical plots using 'layout' .............. ## adjust panel margins to accommodate desired extra separation mar.panel <- pmax(0, mar.panel + c(vsep, hsep, vsep, hsep)/2) ## increase heights to accommodate panel titles if(sizes.known && any(nzchar(main.panel))) heights <- heights * (1 + panel.vpad) ## check for adornment if(!is.null(adorn.left)) { ## add margin at left, of width adorn.size * meanwidth nall <- i.left <- n+1 mat <- cbind(i.left, mat) widths <- c(adorn.size * meanwidth, widths) } if(!is.null(adorn.right)) { ## add margin at right, of width adorn.size * meanwidth nall <- i.right <- nall+1 mat <- cbind(mat, i.right) widths <- c(widths, adorn.size * meanwidth) } if(!is.null(adorn.bottom)) { ## add margin at bottom, of height adorn.size * meanheight nall <- i.bottom <- nall+1 mat <- rbind(mat, i.bottom) heights <- c(heights, adorn.size * meanheight) } if(!is.null(adorn.top)) { ## add margin at top, of height adorn.size * meanheight nall <- i.top <- nall + 1 mat <- rbind(i.top, mat) heights <- c(adorn.size * meanheight, heights) } if(banner) { ## Increment existing panel numbers ## New panel 1 is the banner panels <- (mat > 0) mat[panels] <- mat[panels] + 1 mat <- rbind(1, mat) heights <- c(0.1 * meanheight * (1 + nlines), heights) } ## declare layout layout(mat, heights=heights, widths=widths, respect=sizes.known) ## start output ..... ## .... plot banner if(banner) { opa <- par(mar=rep.int(0,4), xpd=TRUE) on.exit(par(opa)) plot(numeric(0),numeric(0),type="n",ann=FALSE,axes=FALSE, xlim=c(-1,1),ylim=c(-1,1)) cex <- resolve.1.default(list(cex.title=1.5), list(...))/par('cex') text(0,0,main, cex=cex) } ## plot panels npa <- par(mar=mar.panel) if(!banner) on.exit(par(npa)) result <- vector(mode="list", length=n) for(i in 1:n) { xi <- x[[i]] exec.or.plot(panel.begin, i, xi, main=main.panel[i], extrargs=extrargs.begin) result <- extraplot(i, xi, ..., add = !is.null(panel.begin), main = main.panel[i], extrargs=extrargs, panel.args=panel.args, plotcommand=plotcommand) %orifnull% list() exec.or.plot(panel.end, i, xi, add=TRUE, extrargs=extrargs.end) } ## adornments if(nall > n) { par(mar=rep.int(0,4), xpd=TRUE) plotadornment(adorn.left, adorn.args) plotadornment(adorn.right, adorn.args) plotadornment(adorn.bottom, adorn.args) plotadornment(adorn.top, adorn.args) } ## revert layout(1) return(invisible(result)) } plot.anylist }) contour.imlist <- contour.listof <- function(x, ...) { xname <- short.deparse(substitute(x)) force(x) do.call(plot.solist, resolve.defaults(list(x=quote(x), plotcommand="contour"), list(...), list(main=xname))) } plot.imlist <- local({ plot.imlist <- function(x, ..., plotcommand="image", equal.ribbon = FALSE, equal.scales = FALSE, ribmar=NULL) { xname <- short.deparse(substitute(x)) force(x) if(missing(plotcommand) && any(sapply(x, inherits, what=c("linim", "linfun")))) plotcommand <- "plot" if(equal.ribbon && (list(plotcommand) %in% list("image", "plot", image, plot))) { out <- imagecommon(x, ..., xname=xname, ribmar=ribmar, equal.scales=equal.scales) } else { out <- do.call(plot.solist, resolve.defaults(list(x=quote(x), plotcommand=plotcommand), list(...), list(main=xname, equal.scales=equal.scales))) } return(invisible(out)) } sideCode <- function(side) { if(is.numeric(side)) { stopifnot(side %in% 1:4) sidecode <- side } else if(is.character(side)) { stopifnot(side %in% c("bottom", "left", "top", "right")) sidecode <- match(side, c("bottom", "left", "top", "right")) } else stop("Unrecognised format for 'side'") return(sidecode) } imagecommon <- function(x, ..., xname, zlim=NULL, equal.scales=FALSE, ribbon=TRUE, ribside=c("right", "left", "bottom", "top"), ribsep=NULL, ribwid=0.5, ribn=1024, ribscale=NULL, ribargs=list(), ribmar = NULL, mar.panel = c(2,1,1,2)) { if(missing(xname)) xname <- short.deparse(substitute(x)) force(x) ribside <- match.arg(ribside) stopifnot(is.list(ribargs)) if(!is.null(ribsep)) warning("Argument ribsep is not yet implemented for image arrays") ## ascertain types of pixel values xtypes <- sapply(x, getElement, name="type") ischar <- (xtypes == "character") if(any(ischar)) { ## convert character-valued images to factor-valued strings <- unique(unlist(lapply(x[ischar], "["))) x[ischar] <- lapply(x[ischar], factorimage, levels=strings) xtypes[ischar] <- "factor" } isfactor <- xtypes == "factor" isnumeric <- xtypes %in% c("real", "integer", "logical") if(all(isnumeric)) { ## determine range of values for colour map if(is.null(zlim)) zlim <- range(unlist(lapply(x, range))) ## determine common colour map based on zlim imcolmap <- plot.im(x[[1L]], do.plot=FALSE, zlim=zlim, ..., ribn=ribn) } else if(all(isfactor)) { x <- harmoniseLevels(x) ## determine common colour map based on factor levels imcolmap <- plot.im(x[[1L]], do.plot=FALSE, ..., ribn=ribn) } else warning("Could not determine a common colour map for these images", call.=FALSE) ## plot ribbon? if(!ribbon) { ribadorn <- list() } else if(equal.scales) { ## colour ribbon will be aligned with objects in plot ribadorn <- list(adorn=imcolmap, adorn.args=append(ribargs, list(labelmap=ribscale))) names(ribadorn)[1] <- paste("adorn", ribside, sep=".") } else { ## colour ribbon will be "free-floating" ## Determine plot arguments for ribbon vertical <- (ribside %in% c("right", "left")) scaleinfo <- if(!is.null(ribscale)) list(labelmap=ribscale) else list() sidecode <- sideCode(ribside) ribstuff <- c(list(x=imcolmap, main="", vertical=vertical), ribargs, scaleinfo, list(side=sidecode)) if (is.null(mar.panel)) mar.panel <- c(2, 1, 1, 2) if (length(mar.panel) != 4) mar.panel <- rep(mar.panel, 4)[1:4] if (is.null(ribmar)) { ribmar <- mar.panel/2 newmar <- c(2, 0) switch(ribside, left = { ribmar[c(2, 4)] <- newmar }, right = { ribmar[c(4, 2)] <- newmar }, bottom = { ribmar[c(1, 3)] <- newmar }, top = { ribmar[c(3, 1)] <- newmar } ) } ## bespoke function executed to plot colour ribbon do.ribbon <- function() { opa <- par(mar=ribmar) on.exit(par(opa)) do.call(plot, ribstuff) } ## ribbon plot function encoded as 'adorn' argument ribadorn <- list(adorn=do.ribbon, adorn.size=ribwid) names(ribadorn)[1] <- paste("adorn", ribside, sep=".") } ## result <- do.call(plot.solist, resolve.defaults(list(x=quote(x), plotcommand="image"), list(...), list(equal.scales=equal.scales, mar.panel=mar.panel, main=xname, col=imcolmap, zlim=zlim, ribbon=FALSE), ribadorn)) return(invisible(result)) } factorimage <- function(X, levels=NULL) { eval.im(factor(X, levels=levels)) } plot.imlist }) image.imlist <- image.listof <- function(x, ..., equal.ribbon = FALSE, equal.scales=FALSE, ribmar=NULL) { plc <- resolve.1.default(list(plotcommand="image"), list(...)) if(list(plc) %in% list("image", "plot", image, plot)) { out <- plot.imlist(x, ..., plotcommand="image", equal.ribbon=equal.ribbon, equal.scales=equal.scales, ribmar=ribmar) } else { out <- plot.solist(x, ..., equal.scales=equal.scales, ribmar=ribmar) } return(invisible(out)) } spatstat.geom/R/intensity.R0000644000176200001440000000250514611065352015422 0ustar liggesusers# # intensity.R # # Code related to intensity and intensity approximations # # $Revision: 1.24 $ $Date: 2022/05/23 02:33:06 $ # intensity <- function(X, ...) { UseMethod("intensity") } intensity.ppp <- function(X, ..., weights=NULL) { n <- npoints(X) a <- area(Window(X)) if(is.null(weights)) { ## unweighted case - for efficiency if(is.multitype(X)) { mks <- marks(X) answer <- as.vector(table(mks))/a names(answer) <- levels(mks) } else answer <- n/a return(answer) } ## weighted case weights <- pointweights(X, weights=weights, parent=parent.frame()) if(is.multitype(X)) { mks <- marks(X) answer <- as.vector(tapply(weights, mks, sum))/a answer[is.na(answer)] <- 0 names(answer) <- levels(mks) } else { answer <- sum(weights)/a } return(answer) } intensity.splitppp <- function(X, ..., weights=NULL) { if(is.null(weights)) return(sapply(X, intensity.ppp)) if(is.expression(weights)) return(sapply(X, intensity.ppp, weights=weights)) if(is.numeric(weights)) { fsplit <- attr(X, "fsplit") n <- length(fsplit) check.nvector(weights, n, vname="weights") result <- mapply(intensity.ppp, X, weights=split(weights, fsplit)) result <- simplify2array(result, higher=FALSE) return(result) } stop("Unrecognised format for weights") } spatstat.geom/R/ppx.R0000644000176200001440000004416214611065352014210 0ustar liggesusers# # ppx.R # # class of general point patterns in any dimension # # $Revision: 1.72 $ $Date: 2024/04/19 09:24:00 $ # ppx <- local({ ctype.table <- c("spatial", "temporal", "local", "mark") ctype.real <- c(TRUE, TRUE, FALSE, FALSE) ppx <- function(data, domain=NULL, coord.type=NULL, simplify=FALSE) { data <- as.hyperframe(data) # columns suitable for spatial coordinates suitable <- with(unclass(data), vtype == "dfcolumn" & (vclass == "numeric" | vclass == "integer")) if(is.null(coord.type)) { # assume all suitable columns of data are spatial coordinates # and all other columns are marks. ctype <- ifelse(suitable, "spatial", "mark") } else { stopifnot(is.character(coord.type)) stopifnot(length(coord.type) == ncol(data)) ctypeid <- pmatch(coord.type, ctype.table, duplicates.ok=TRUE) # validate if(any(uhoh <- is.na(ctypeid))) stop(paste("Unrecognised coordinate", ngettext(sum(uhoh), "type", "types"), commasep(sQuote(coord.type[uhoh])))) if(any(uhoh <- (!suitable & ctype.real[ctypeid]))) { nuh <- sum(uhoh) stop(paste(ngettext(nuh, "Coordinate", "Coordinates"), commasep(sQuote(names(data)[uhoh])), ngettext(nuh, "does not", "do not"), "contain real numbers")) } ctype <- ctype.table[ctypeid] } ctype <- factor(ctype, levels=ctype.table) # if(simplify && all(ctype == "spatial")) { # attempt to reduce to ppp or pp3 d <- length(ctype) if(d == 2) { ow <- try(as.owin(domain), silent=TRUE) if(!inherits(ow, "try-error")) { X <- try(as.ppp(as.data.frame(data), W=ow)) if(!inherits(X, "try-error")) return(X) } } else if(d == 3) { bx <- try(as.box3(domain), silent=TRUE) if(!inherits(bx, "try-error")) { m <- as.matrix(as.data.frame(data)) X <- try(pp3(m[,1], m[,2], m[,3], bx)) if(!inherits(X, "try-error")) return(X) } } } out <- list(data=data, ctype=ctype, domain=domain) class(out) <- "ppx" return(out) } ppx }) is.ppx <- function(x) { inherits(x, "ppx") } nobjects.ppx <- npoints.ppx <- function(x) { nrow(x$data) } print.ppx <- function(x, ...) { cat("Multidimensional point pattern\n") sd <- summary(x$data) np <- sd$ncases nama <- sd$col.names cat(paste(np, ngettext(np, "point", "points"), "\n")) if(any(iscoord <- (x$ctype == "spatial"))) cat(paste(sum(iscoord), "-dimensional space coordinates ", paren(paste(nama[iscoord], collapse=",")), "\n", sep="")) if(any(istime <- (x$ctype == "temporal"))) cat(paste(sum(istime), "-dimensional time coordinates ", paren(paste(nama[istime], collapse=",")), "\n", sep="")) if(any(islocal <- (x$ctype == "local"))) cat(paste(sum(islocal), ngettext(sum(islocal), "column", "columns"), "of local coordinates:", commasep(sQuote(nama[islocal])), "\n")) if(any(ismark <- (x$ctype == "mark"))) cat(paste(sum(ismark), ngettext(sum(ismark), "column", "columns"), "of marks:", commasep(sQuote(nama[ismark])), "\n")) if(!is.null(x$domain)) { cat("Domain:\n\t") print(x$domain) } invisible(NULL) } summary.ppx <- function(object, ...) { object } plot.ppx <- function(x, ...) { xname <- short.deparse(substitute(x)) coo <- coords(x, local=FALSE) dom <- x$domain m <- ncol(coo) if(m == 1) { coo <- coo[,1] ran <- diff(range(coo)) ylim <- c(-1,1) * ran/20 do.call(plot.default, resolve.defaults(list(quote(coo), numeric(length(coo))), list(...), list(asp=1, ylim=ylim, axes=FALSE, xlab="", ylab=""))) axis(1, pos=ylim[1]) } else if(m == 2) { if(is.null(dom)) { # plot x, y coordinates only nama <- names(coo) xx <- coo[,1L] yy <- coo[,2L] dont.complain.about(xx, yy) do.call.matched(plot.default, resolve.defaults(list(x=quote(xx), y=quote(yy), asp=1), list(...), list(main=xname), list(xlab=nama[1L], ylab=nama[2L]))) } else { add <- resolve.defaults(list(...), list(add=FALSE))$add if(!add) { # plot domain, whatever it is do.call(plot, resolve.defaults(list(quote(dom)), list(...), list(main=xname))) } ## convert to ppp x2 <- ppp(coo[,1], coo[,2], window=as.owin(dom), marks=as.data.frame(marks(x)), check=FALSE) ## invoke plot.ppp dont.complain.about(x2) return(do.call(plot, resolve.defaults(list(quote(x2)), list(add=TRUE), list(...)))) } } else if(m == 3) { # convert to pp3 if(is.null(dom)) dom <- box3(range(coo[,1]), range(coo[,2]), range(coo[,3])) x3 <- pp3(coo[,1], coo[,2], coo[,3], dom) # invoke plot.pp3 nama <- names(coo) dont.complain.about(x3) do.call(plot, resolve.defaults(list(quote(x3)), list(...), list(main=xname), list(xlab=nama[1], ylab=nama[2], zlab=nama[3]))) } else stop(paste("Don't know how to plot a general point pattern in", ncol(coo), "dimensions")) return(invisible(NULL)) } is.boxx <- function(x){ inherits(x, "boxx") } intersect.boxx <- function(..., fatal = FALSE){ argh <- list(...) ## look for NULL arguments (empty boxx) and return NULL if(any(sapply(argh, is.null))){ if(fatal) stop("There is a NULL boxx in the intersection.") return(NULL) } ## look for boxx arguments isboxx <- sapply(argh, is.boxx) if(any(!isboxx)) warning("Some arguments were not boxx objects") argh <- argh[isboxx] nboxx <- length(argh) if(nboxx == 0) { warning("No non-NULL boxx objects were given") if(fatal) stop("The intersection of boxx objects is NULL.") return(NULL) } ## at least one boxx A <- argh[[1L]] if(nboxx == 1) return(A) ## at least two non-empty boxx objects B <- argh[[2L]] if(nboxx > 2) { ## handle union of more than two windows windows <- argh[-c(1,2)] ## absorb all windows into B for(i in seq_along(windows)) { B <- do.call(intersect.boxx, list(B, windows[[i]], fatal=fatal)) if(is.null(B)){ if(fatal) stop("The intersection of boxx objects is NULL.") return(NULL) } } } ## There are now only two windows, which are not empty. if(identical(A, B)){ return(A) } # check dim and units if(spatdim(A)!=spatdim(B)){ stop("Not all boxx objects have same spatial dimension.") } if(!compatible(unitname(A), unitname(B))) warning("The two windows have incompatible units of length") uname <- harmonise(unitname(A), unitname(B), single=TRUE) # determine intersection of ranges rA <- A$ranges rB <- B$ranges r1 <- pmax(rA[1,], rB[1,]) r2 <- pmin(rA[2,], rB[2,]) if(any(r1>=r2)){ if(fatal) stop("The intersection of boxx objects is NULL.") return(NULL) } return(boxx(rbind(r1,r2), unitname=uname)) } "[.ppx" <- function (x, i, drop=FALSE, clip=FALSE, ...) { da <- x$data dom <- x$domain if(!missing(i)) { if(inherits(i, c("boxx", "box3"))) { if(clip){ dom <- intersect.boxx(dom, i) } else{ dom <- i } if(is.null(dom)){ i <- rep(FALSE, nrow(da)) } else{ i <- inside.boxx(da, w=i) } } da <- da[i, , drop=FALSE] } out <- list(data=da, ctype=x$ctype, domain=dom) class(out) <- "ppx" if(drop) { # remove unused factor levels mo <- marks(out) switch(markformat(mo), none = { }, vector = { if(is.factor(mo)) marks(out) <- factor(mo) }, dataframe = { isfac <- sapply(mo, is.factor) if(any(isfac)) mo[, isfac] <- lapply(mo[, isfac], factor) marks(out) <- mo }, hyperframe = { lmo <- as.list(mo) isfac <- sapply(lmo, is.factor) if(any(isfac)) mo[, isfac] <- as.hyperframe(lapply(lmo[isfac], factor)) marks(out) <- mo }) } return(out) } domain <- function(X, ...) { UseMethod("domain") } domain.ppx <- function(X, ...) { X$domain } coords <- function(x, ...) { UseMethod("coords") } coords.ppx <- function(x, ..., spatial=TRUE, temporal=TRUE, local=TRUE) { ctype <- x$ctype chosen <- (ctype == "spatial" & spatial) | (ctype == "temporal" & temporal) | (ctype == "local" & local) as.data.frame(x$data[, chosen, drop=FALSE]) } coords.ppp <- function(x, ...) { data.frame(x=x$x,y=x$y) } "coords<-" <- function(x, ..., value) { UseMethod("coords<-") } "coords<-.ppp" <- function(x, ..., value) { win <- x$window if(is.null(value)) { # empty pattern return(ppp(window=win)) } value <- as.data.frame(value) if(ncol(value) != 2) stop("Expecting a 2-column matrix or data frame, or two vectors") result <- as.ppp(value, win, ...) marks(result) <- marks(x) return(result) } "coords<-.ppx" <- function(x, ..., spatial=TRUE, temporal=TRUE, local=TRUE, value) { ctype <- x$ctype chosen <- (ctype == "spatial" & spatial) | (ctype == "temporal" & temporal) | (ctype == "local" & local) x$data[, chosen] <- value return(x) } as.hyperframe.ppx <- function(x, ...) { x$data } as.data.frame.ppx <- function(x, ...) { as.data.frame(x$data, ...) } as.matrix.ppx <- function(x, ...) { as.matrix(as.data.frame(x, ...)) } marks.ppx <- function(x, ..., drop=TRUE) { ctype <- x$ctype chosen <- (ctype == "mark") if(!any(chosen)) return(NULL) x$data[, chosen, drop=drop] } "marks<-.ppx" <- function(x, ..., value) { ctype <- x$ctype retain <- (ctype != "mark") coorddata <- x$data[, retain, drop=FALSE] if(is.null(value)) { newdata <- coorddata newctype <- ctype[retain] } else { if(is.matrix(value) && nrow(value) == nrow(x$data)) { # assume matrix is to be treated as data frame value <- as.data.frame(value) } if(!is.data.frame(value) && !is.hyperframe(value)) value <- hyperframe(marks=value) if(is.hyperframe(value) || is.hyperframe(coorddata)) { value <- as.hyperframe(value) coorddata <- as.hyperframe(coorddata) } if(ncol(value) == 0) { newdata <- coorddata newctype <- ctype[retain] } else { if(nrow(coorddata) == 0) value <- value[integer(0), , drop=FALSE] newdata <- cbind(coorddata, value) newctype <- factor(c(as.character(ctype[retain]), rep.int("mark", ncol(value))), levels=levels(ctype)) } } out <- list(data=newdata, ctype=newctype, domain=x$domain) class(out) <- class(x) return(out) } unmark.ppx <- function(X) { marks(X) <- NULL return(X) } markformat.ppx <- function(x) { mf <- x$markformat if(is.null(mf)) mf <- markformat(marks(x)) return(mf) } boxx <- function(..., unitname=NULL) { if(length(list(...)) == 0) stop("No data") ranges <- data.frame(...) nama <- names(list(...)) if(is.null(nama) || !all(nzchar(nama))) names(ranges) <- paste("x", 1:ncol(ranges),sep="") if(nrow(ranges) != 2) stop("Data should be vectors of length 2") if(any(unlist(lapply(ranges, diff)) <= 0)) stop("Illegal range: Second element <= first element") out <- list(ranges=ranges, units=as.unitname(unitname)) class(out) <- "boxx" return(out) } as.boxx <- function(..., warn.owin = TRUE) { a <- list(...) n <- length(a) if (n == 0) stop("No arguments given") if (n == 1) { a <- a[[1]] if (inherits(a, "boxx")) return(a) if (inherits(a, "box3")) return(boxx(a$xrange, a$yrange, a$zrange, unitname = as.unitname(a$units))) if (inherits(a, "owin")) { if (!is.rectangle(a) && warn.owin) warning("The owin object does not appear to be rectangular - the bounding box is used!") return(boxx(a$xrange, a$yrange, unitname = as.unitname(a$units))) } if (is.numeric(a)) { if ((length(a)%%2) == 0) return(boxx(split(a, rep(1:(length(a)/2), each = 2)))) stop(paste("Don't know how to interpret", length(a), "numbers as a box")) } if (!is.list(a)) stop("Don't know how to interpret data as a box") } return(do.call(boxx, a)) } print.boxx <- function(x, ...) { m <- ncol(x$ranges) cat(paste(m, "-dimensional box:\n", sep="")) bracket <- function(z) paste("[", paste(signif(z, 5), collapse=", "), "]", sep="") v <- paste(unlist(lapply(x$ranges, bracket)), collapse=" x ") s <- summary(unitname(x)) cat(paste(v, s$plural, s$explain, "\n")) invisible(NULL) } unitname.boxx <- function(x) { as.unitname(x$units) } "unitname<-.boxx" <- function(x, value) { x$units <- as.unitname(value) return(x) } unitname.ppx <- function(x) { unitname(x$domain) } "unitname<-.ppx" <- function(x, value) { d <- x$domain unitname(d) <- value x$domain <- d return(x) } as.owin.boxx <- function(W, ..., fatal=TRUE) { ra <- W$ranges if(length(ra) == 2) return(owinInternalRect(ra[[1]], ra[[2]])) if(fatal) stop(paste("Cannot interpret box of dimension", length(ra), "as a window")) return(NULL) } sidelengths.boxx <- function(x) { stopifnot(inherits(x, "boxx")) y <- unlist(lapply(x$ranges, diff)) return(y) } volume.boxx <- function(x) { prod(sidelengths(x)) } diameter.boxx <- function(x) { d <- sqrt(sum(sidelengths(x)^2)) return(d) } shortside.boxx <- function(x) { return(min(sidelengths(x))) } eroded.volumes.boxx <- local({ eroded.volumes.boxx <- function(x, r) { len <- sidelengths(x) ero <- sapply(as.list(len), erode1side, r=r) apply(ero, 1, prod) } erode1side <- function(z, r) { pmax.int(0, z - 2 * r)} eroded.volumes.boxx }) unique.ppx <- function(x, ..., warn=FALSE) { dup <- duplicated(x, ...) if(!any(dup)) return(x) if(warn) warning(paste(sum(dup), "duplicated points were removed"), call.=FALSE) y <- x[!dup] return(y) } duplicated.ppx <- function(x, ...) { dup <- duplicated(as.data.frame(x), ...) return(dup) } anyDuplicated.ppx <- function(x, ...) { anyDuplicated(as.data.frame(x), ...) } multiplicity.ppx <- function(x) { mul <- multiplicity(as.data.frame(x)) return(mul) } intensity.ppx <- function(X, ...) { if(!is.multitype(X)) { n <- npoints(X) } else { mks <- marks(X) n <- as.vector(table(mks)) names(n) <- levels(mks) } v <- volume(domain(X)) return(n/v) } grow.boxx <- function(W, left, right = left){ W <- as.boxx(W) ra <- W$ranges d <- length(ra) if(any(left < 0) || any(right < 0)) stop("values of left and right margin must be nonnegative.") if(length(left)==1) left <- rep(left, d) if(length(right)==1) right <- rep(right, d) if(length(left)!=d || length(right)!=d){ stop("left and right margin must be either of length 1 or the dimension of the boxx.") } W$ranges[1,] <- ra[1,]-left W$ranges[2,] <- ra[2,]+right return(W) } inside.boxx <- function(..., w = NULL){ if(is.null(w)) stop("Please provide a boxx using the named argument w.") w <- as.boxx(w) dat <- list(...) if(length(dat)==1){ dat1 <- dat[[1]] if(inherits(dat1, "ppx")) dat <- coords(dat1) if(inherits(dat1, c("hyperframe", "data.frame", "matrix"))) dat <- as.data.frame(dat1) } ra <- w$ranges if(length(ra)!=length(dat)) stop("Mismatch between dimension of boxx and number of coordinate vectors.") ## Check coord. vectors have equal length n <- length(dat[[1]]) if(any(lengths(dat)!=n)) stop("Coordinate vectors have unequal length.") index <- rep(TRUE, n) for(i in seq_along(ra)){ index <- index & inside.range(dat[[i]], ra[[i]]) } return(index) } spatdim <- function(X, intrinsic=FALSE) { if(intrinsic) { if(inherits(X, c("lpp", "linnet", "linim", "linfun", "lintess"))) return(1L) if(inherits(X, c("s2pp", "s2", "s2region"))) return(2L) } if(is.sob(X)) 2L else if(inherits(X, "box3")) 3L else if(inherits(X, "boxx")) length(X$ranges) else if(is.ppx(X)) as.integer(sum(X$ctype == "spatial")) else NA_integer_ } shift.boxx <- function(X, vec = 0, ...){ ra <- X$ranges if(length(vec)==1){ vec <- rep(vec, ncol(ra)) } stopifnot(length(vec)==ncol(ra)) X$ranges <- ra + matrix(vec, 2L, ncol(ra), byrow = TRUE) attr(X, "lastshift") <- vec return(X) } shift.ppx <- function(X, vec = 0, ..., spatial = TRUE, temporal = TRUE, local = TRUE){ ctype <- X$ctype chosen <- (ctype == "spatial" & spatial) | (ctype == "temporal" & temporal) | (ctype == "local" & local) dat <- as.data.frame(X$data[, chosen, drop=FALSE]) if(length(vec)==1){ vec <- rep(vec, ncol(dat)) } stopifnot(length(vec)==ncol(dat)) X$data[,chosen] <- dat + matrix(vec, nrow(dat), ncol(dat), byrow = TRUE) X$domain <- shift(X$domain, vec = vec) attr(X, "lastshift") <- vec return(X) } # Scale a boxx and ppx like base::scale() scale.boxx <- function(x, center=TRUE, scale=TRUE){ newranges <- scale(x$ranges, center, scale) x$ranges <- as.data.frame(newranges) attr(x, "scaled:center") <- attr(newranges, "scaled:center") attr(x, "scaled:scale") <- attr(newranges, "scaled:scale") return(x) } scale.ppx <- function(x, center=TRUE, scale=TRUE){ if(!is.null(domain(x))){ x$domain <- newdomain <- scale(domain(x), center, scale) newcenter <- attr(newdomain, "scaled:center") newscale <- attr(newdomain, "scaled:scale") if(!is.null(newcenter) && !is.null(newscale)) { center <- newcenter scale <- newscale } } coords(x) <- newcoords <- scale(coords(x), center, scale) attr(x, "scaled:center") <- attr(newcoords, "scaled:center") attr(x, "scaled:scale") <- attr(newcoords, "scaled:scale") return(x) } spatstat.geom/R/eval.im.R0000644000176200001440000002245514611065351014734 0ustar liggesusers# # eval.im.R # # eval.im() Evaluate expressions involving images # # compatible.im() Check whether two images are compatible # # harmonise.im() Harmonise images # commonGrid() # # $Revision: 1.55 $ $Date: 2020/12/06 03:58:18 $ # eval.im <- local({ eval.im <- function(expr, envir, harmonize=TRUE, warn=TRUE) { e <- as.expression(substitute(expr)) ## get names of all variables in the expression varnames <- all.vars(e) allnames <- all.names(e, unique=TRUE) funnames <- allnames[!(allnames %in% varnames)] if(length(varnames) == 0) stop("No variables in this expression") ## get the values of the variables if(missing(envir)) { envir <- parent.frame() # WAS: sys.parent() } else if(is.list(envir)) { envir <- list2env(envir, parent=parent.frame()) } vars <- mget(varnames, envir=envir, inherits=TRUE, ifnotfound=list(NULL)) funs <- mget(funnames, envir=envir, inherits=TRUE, ifnotfound=list(NULL)) ## WAS: vars <- lapply(as.list(varnames), get, envir=envir) ## WAS: funs <- lapply(as.list(funnames), get, envir=envir) ## ## find out which variables are images ims <- unlist(lapply(vars, is.im)) if(!any(ims)) stop("No images in this expression") images <- vars[ims] nimages <- length(images) ## test that the images are compatible if(!(do.call(compatible, unname(images)))) { whinge <- paste(if(nimages > 2) "some of" else NULL, "the images", commasep(sQuote(names(images))), if(!harmonize) "are" else "were", "not compatible") if(!harmonize) { stop(whinge, call.=FALSE) } else if(warn) { warning(whinge, call.=FALSE) } images <- do.call(harmonise.im, images) } ## trap a common error: using fv object as variable isfun <- unlist(lapply(vars, is.fv)) if(any(isfun)) stop("Cannot use objects of class fv as variables in eval.im") ## replace each image by its matrix of pixel values, and evaluate imagevalues <- lapply(images, getImValues) template <- images[[1L]] ## This bit has been repaired: vars[ims] <- imagevalues v <- eval(e, append(vars, funs)) ## ## reshape, etc result <- im(v, xcol=template$xcol, yrow=template$yrow, xrange=template$xrange, yrange=template$yrange, unitname=unitname(template)) return(result) } ## extract pixel values without destroying type information getImValues <- function(x) { v <- as.matrix(x) dim(v) <- NULL return(v) } eval.im }) compatible.im <- function(A, B, ..., tol=1e-6) { verifyclass(A, "im") if(missing(B)) return(TRUE) verifyclass(B, "im") if(!all(A$dim == B$dim)) return(FALSE) xdiscrep <- max(abs(A$xrange - B$xrange), abs(A$xstep - B$xstep), abs(A$xcol - B$xcol)) ydiscrep <- max(abs(A$yrange - B$yrange), abs(A$ystep - B$ystep), abs(A$yrow - B$yrow)) xok <- (xdiscrep < tol * min(A$xstep, B$xstep)) yok <- (ydiscrep < tol * min(A$ystep, B$ystep)) uok <- compatible.unitname(unitname(A), unitname(B)) if(!(xok && yok && uok)) return(FALSE) ## A and B are compatible if(length(list(...)) == 0) return(TRUE) ## recursion return(compatible.im(B, ..., tol=tol)) } ## force a list of images to be compatible harmonize <- harmonise <- function(...) { UseMethod("harmonise") } harmonize.im <- harmonise.im <- function(...) { argz <- list(...) n <- length(argz) if(n < 2) return(argz) result <- vector(mode="list", length=n) isim <- unlist(lapply(argz, is.im)) if(!any(isim)) stop("No images supplied") imgs <- argz[isim] ## if any windows are present, extract bounding box iswin <- unlist(lapply(argz, is.owin)) bb0 <- if(!any(iswin)) NULL else do.call(boundingbox, unname(argz[iswin])) if(length(imgs) == 1L && is.null(bb0)) { ## only one 'true' image: use it as template. result[isim] <- imgs Wtemplate <- imgs[[1L]] } else { ## test for compatible units un <- lapply(imgs, unitname) uok <- unlist(lapply(un, compatible.unitname, y=un[[1L]])) if(!all(uok)) stop("Images have incompatible units of length") ## find the image with the highest resolution xsteps <- unlist(lapply(imgs, getElement, name="xstep")) which.finest <- which.min(xsteps) finest <- imgs[[which.finest]] ## get the bounding box bb <- do.call(boundingbox, lapply(unname(imgs), as.rectangle)) if(!is.null(bb0)) bb <- boundingbox(bb, bb0) ## determine new raster coordinates xcol <- prolongseq(finest$xcol, bb$xrange) yrow <- prolongseq(finest$yrow, bb$yrange) xy <- list(x=xcol, y=yrow) ## resample all images on new raster newimgs <- lapply(imgs, as.im, xy=xy) result[isim] <- newimgs Wtemplate <- newimgs[[which.finest]] } ## convert other data to images if(any(notim <- !isim)) result[notim] <- lapply(argz[notim], as.im, W=as.mask(Wtemplate)) names(result) <- names(argz) result <- as.solist(result) return(result) } ## Return just the corresponding template window commonGrid <- local({ ## auxiliary function gettype <- function(x) { if(is.im(x) || is.mask(x)) "raster" else if(is.owin(x) || is.ppp(x) || is.psp(x)) "spatial" else "none" } commonGrid <- function(...) { argz <- list(...) type <- unlist(lapply(argz, gettype)) israster <- (type == "raster") haswin <- (type != "none") if(any(israster)) { ## Get raster data rasterlist <- argz[israster] } else { ## No existing raster data - apply default resolution if(!any(haswin)) stop("No spatial data supplied") wins <- lapply(argz[haswin], as.owin) rasterlist <- lapply(wins, as.mask) } ## Find raster object with finest resolution if(length(rasterlist) == 1L) { ## only one raster object finest <- rasterlist[[1L]] } else { ## test for compatible units un <- lapply(rasterlist, unitname) uok <- unlist(lapply(un, compatible.unitname, y=un[[1L]])) if(!all(uok)) stop("Objects have incompatible units of length") ## find the image/mask with the highest resolution xsteps <- unlist(lapply(rasterlist, getElement, name="xstep")) which.finest <- which.min(xsteps) finest <- rasterlist[[which.finest]] } ## determine the bounding box bb <- do.call(boundingbox, lapply(unname(argz[haswin]), as.rectangle)) ## determine new raster coordinates xcol <- prolongseq(finest$xcol, bb$xrange) yrow <- prolongseq(finest$yrow, bb$yrange) xy <- list(x=xcol, y=yrow) ## generate template Wtemplate <- as.mask(bb, xy=xy) return(Wtemplate) } commonGrid }) im.apply <- function(X, FUN, ..., fun.handles.na=FALSE, check=TRUE) { if(!inherits(X, "imlist")) { stopifnot(is.list(X)) if(!all(sapply(X, is.im))) stop("All elements of X must be pixel images") } ## determine function to be applied fun <- if(is.character(FUN)) get(FUN, mode="function") else if(is.function(FUN)) FUN else stop("Unrecognised format for FUN") funcode <- match(list(fun), list(base::sum, base::mean, base::mean.default, stats::var, stats::sd), nomatch=0L) funtype <- c("general", "sum", "mean", "mean", "var", "sd")[funcode+1L] if(funcode != 0) na.rm <- resolve.1.default(list(na.rm=FALSE), list(...)) ## ensure images are compatible if(check && !do.call(compatible, unname(X))) X <- do.call(harmonise.im, X) template <- X[[1L]] d <- dim(template) ## extract numerical values and convert to matrix with one column per image vals <- sapply(X, getElement, name="v") ## apply to all pixels ? full <- fun.handles.na || !anyNA(vals) if(!full) { ## NA present ok <- complete.cases(vals) if(!any(ok)) { ## empty result return(as.im(NA, W=template)) } ## restrict to pixels where all data are non-NA vals <- vals[ok, , drop=FALSE] } n <- nrow(vals) ## calculate y <- switch(funtype, general = apply(vals, 1L, fun, ...), sum = rowSums(vals, na.rm=na.rm), mean = rowMeans(vals, na.rm = na.rm), sd = , var = { sumx <- rowSums(vals, na.rm = na.rm) sumx2 <- rowSums(vals^2, na.rm = na.rm) if(!anyNA(vals)) { m <- ncol(vals) v <- (sumx2 - sumx^2/m)/(m-1) } else { m <- rowSums(!is.na(vals)) v <- ifelse(m < 2, NA, (sumx2 - sumx^2/m)/(m-1)) } if(funtype == "var") v else sqrt(v) }) if(funtype == "general" && length(y) != n) stop("FUN should yield one value per pixel") if(!full) { ## put the NA's back (preserving type of 'y') yfull <- rep(y[1L], prod(d)) yfull[ok] <- y yfull[!ok] <- NA y <- yfull } ## pack up (preserving type of 'y') result <- im(y, xcol=template$xcol, yrow=template$yrow, xrange=template$xrange, yrange=template$yrange, unitname=template$unitname) return(result) } spatstat.geom/R/wingeom.R0000644000176200001440000007512414611065353015051 0ustar liggesusers# # wingeom.R Various geometrical computations in windows # # $Revision: 4.142 $ $Date: 2024/02/04 08:04:51 $ # volume.owin <- function(x) { area.owin(x) } area <- function(w) UseMethod("area") area.default <- function(w) area.owin(as.owin(w)) area.owin <- function(w) { stopifnot(is.owin(w)) switch(w$type, rectangle = { width <- abs(diff(w$xrange)) height <- abs(diff(w$yrange)) area <- width * height }, polygonal = { area <- sum(unlist(lapply(w$bdry, Area.xypolygon))) }, mask = { pixelarea <- abs(w$xstep * w$ystep) npixels <- sum(w$m) area <- pixelarea * npixels }, stop("Unrecognised window type") ) return(area) } perimeter <- function(w) { w <- as.owin(w) switch(w$type, rectangle = { return(2*(diff(w$xrange)+diff(w$yrange))) }, polygonal={ return(sum(lengths_psp(edges(w)))) }, mask={ p <- as.polygonal(w) if(is.null(p)) return(NA) delta <- sqrt(w$xstep^2 + w$ystep^2) p <- simplify.owin(p, delta * 1.15) return(sum(lengths_psp(edges(p)))) }) return(NA) } framebottomleft <- function(w) { f <- Frame(w) c(f$xrange[1L], f$yrange[1L]) } sidelengths.owin <- function(x) { if(x$type != "rectangle") warning("Computing the side lengths of a non-rectangular window") with(x, c(diff(xrange), diff(yrange))) } shortside.owin <- function(x) { min(sidelengths(x)) } eroded.areas <- function(w, r, subset=NULL) { w <- as.owin(w) if(!is.null(subset) && !is.mask(w)) w <- as.mask(w) switch(w$type, rectangle = { width <- abs(diff(w$xrange)) height <- abs(diff(w$yrange)) areas <- pmax(width - 2 * r, 0) * pmax(height - 2 * r, 0) }, polygonal = { ## warning("Approximating polygonal window by digital image") w <- as.mask(w) areas <- eroded.areas(w, r) }, mask = { ## distances from each pixel to window boundary b <- if(is.null(subset)) bdist.pixels(w, style="matrix") else bdist.pixels(w)[subset, drop=TRUE, rescue=FALSE] ## histogram breaks to satisfy hist() Bmax <- max(b, r) breaks <- c(-1,r,Bmax+1) ## histogram of boundary distances h <- hist(b, breaks=breaks, plot=FALSE)$counts ## reverse cumulative histogram H <- revcumsum(h) ## drop first entry corresponding to r=-1 H <- H[-1] ## convert count to area pixarea <- w$xstep * w$ystep areas <- pixarea * H }, stop("unrecognised window type") ) areas } even.breaks.owin <- function(w) { verifyclass(w, "owin") Rmax <- diameter(w) make.even.breaks(bmax=Rmax, npos=128) } unit.square <- function() { owin(c(0,1),c(0,1)) } square <- function(r=1, unitname=NULL) { stopifnot(is.numeric(r)) if(is.numeric(unitname) && length(unitname) == 1 && length(r) == 1) { #' common error warning("Interpreting square(a, b) as square(c(a,b))", call.=FALSE) r <- c(r, unitname) unitname <- NULL } if(!all(is.finite(r))) stop("argument r is NA or infinite") if(length(r) == 1) { stopifnot(r > 0) r <- c(0,r) } else if(length(r) == 2) { stopifnot(r[1L] < r[2L]) } else stop("argument r must be a single number, or a vector of length 2") owinInternalRect(r,r, unitname=unitname) } # convert polygonal window to mask window owinpoly2mask <- function(w, rasta, check=TRUE) { if(check) { verifyclass(w, "owin") stopifnot(is.polygonal(w)) verifyclass(rasta, "owin") stopifnot(is.mask(rasta)) } bdry <- w$bdry x0 <- rasta$xcol[1L] y0 <- rasta$yrow[1L] xstep <- rasta$xstep ystep <- rasta$ystep dimyx <- rasta$dim nx <- dimyx[2L] ny <- dimyx[1L] score <- 0 if(xstep > 0 && ystep > 0) { epsilon <- with(.Machine, double.base^floor(double.ulp.digits/2)) for(i in seq_along(bdry)) { p <- bdry[[i]] xp <- p$x yp <- p$y np <- length(p$x) ## repeat last vertex xp <- c(xp, xp[1L]) yp <- c(yp, yp[1L]) np <- np + 1 ## rescale coordinates so that pixels are at integer locations xp <- (xp - x0)/xstep yp <- (yp - y0)/ystep ## avoid exact integer locations for vertices whole <- (ceiling(xp) == floor(xp)) xp[whole] <- xp[whole] + epsilon whole <- (ceiling(yp) == floor(yp)) yp[whole] <- yp[whole] + epsilon ## call C z <- .C(SG_poly2imI, xp=as.double(xp), yp=as.double(yp), np=as.integer(np), nx=as.integer(nx), ny=as.integer(ny), out=as.integer(integer(nx * ny)), PACKAGE="spatstat.geom") score <- if(i == 1) z$out else (score + z$out) } } status <- (score != 0) out <- owin(rasta$xrange, rasta$yrange, mask=matrix(status, ny, nx)) return(out) } overlap.owin <- function(A, B) { # compute the area of overlap between two windows # check units if(!compatible(unitname(A), unitname(B))) warning("The two windows have incompatible units of length") At <- A$type Bt <- B$type if(At=="rectangle" && Bt=="rectangle") { xmin <- max(A$xrange[1L],B$xrange[1L]) xmax <- min(A$xrange[2L],B$xrange[2L]) if(xmax <= xmin) return(0) ymin <- max(A$yrange[1L],B$yrange[1L]) ymax <- min(A$yrange[2L],B$yrange[2L]) if(ymax <= ymin) return(0) return((xmax-xmin) * (ymax-ymin)) } if((At=="rectangle" && Bt=="polygonal") || (At=="polygonal" && Bt=="rectangle") || (At=="polygonal" && Bt=="polygonal")) { AA <- as.polygonal(A)$bdry BB <- as.polygonal(B)$bdry area <- 0 for(i in seq_along(AA)) for(j in seq_along(BB)) area <- area + overlap.xypolygon(AA[[i]], BB[[j]]) # small negative numbers can occur due to numerical error return(max(0, area)) } if(At=="mask") { # count pixels in A that belong to B pixelarea <- abs(A$xstep * A$ystep) rxy <- rasterxy.mask(A, drop=TRUE) x <- rxy$x y <- rxy$y ok <- inside.owin(x, y, B) return(pixelarea * sum(ok)) } if(Bt== "mask") { # count pixels in B that belong to A pixelarea <- abs(B$xstep * B$ystep) rxy <- rasterxy.mask(B, drop=TRUE) x <- rxy$x y <- rxy$y ok <- inside.owin(x, y, A) return(pixelarea * sum(ok)) } stop("Internal error") } # # subset operator for window # "[.owin" <- function(x, i, ...) { if(!missing(i) && !is.null(i)) { if(is.im(i) && i$type == "logical") { # convert to window i <- as.owin(eval.im(ifelse1NA(i))) } else stopifnot(is.owin(i)) x <- intersect.owin(x, i, fatal=FALSE) } return(x) } # # # Intersection and union of windows # # intersect.owin <- function(..., fatal=FALSE, p) { argh <- list(...) ## p is a list of arguments to polyclip::polyclip if(missing(p) || is.null(p)) p <- list() ## handle 'solist' objects argh <- expandSpecialLists(argh, "solist") rasterinfo <- list() if(length(argh) > 0) { # explicit arguments controlling raster info israster <- names(argh) %in% names(formals(as.mask)) if(any(israster)) { rasterinfo <- argh[israster] ## remaining arguments argh <- argh[!israster] } } ## look for window arguments isowin <- as.logical(sapply(argh, is.owin)) if(any(!isowin)) warning("Some arguments were not windows") argh <- argh[isowin] nwin <- length(argh) if(nwin == 0) { warning("No windows were given") return(NULL) } ## at least one window A <- argh[[1L]] if(is.empty(A)) { if(fatal) stop("Intersection is empty", call.=FALSE) return(A) } if(nwin == 1) return(A) ## at least two windows B <- argh[[2L]] if(is.empty(B)) { if(fatal) stop("Intersection is empty", call.=FALSE) return(B) } if(nwin > 2) { ## handle union of more than two windows windows <- argh[-c(1,2)] ## determine a common set of parameters for polyclip p <- commonPolyclipArgs(A, B, do.call(boundingbox, windows), p=p) ## absorb all windows into B for(i in seq_along(windows)) { B <- do.call(intersect.owin, append(list(B, windows[[i]], p=p, fatal=fatal), rasterinfo)) if(is.empty(B)) return(B) } } ## There are now only two windows, which are not empty. if(identical(A, B)) return(A) # check units if(!compatible(unitname(A), unitname(B))) warning("The two windows have incompatible units of length") uname <- harmonise(unitname(A), unitname(B), single=TRUE) # determine intersection of x and y ranges xr <- intersect.ranges(A$xrange, B$xrange, fatal=fatal) yr <- intersect.ranges(A$yrange, B$yrange, fatal=fatal) if(!fatal && (is.null(xr) || is.null(yr))) return(emptywindow(A)) #' non-empty intersection of Frames C <- owinInternalRect(xr, yr, unitname=uname) # Determine type of intersection Arect <- is.rectangle(A) Brect <- is.rectangle(B) # Apoly <- is.polygonal(A) # Bpoly <- is.polygonal(B) Amask <- is.mask(A) Bmask <- is.mask(B) # Rectangular case if(Arect && Brect) return(C) if(!Amask && !Bmask) { ####### Result is polygonal ############ a <- lapply(as.polygonal(A)$bdry, reverse.xypolygon) b <- lapply(as.polygonal(B)$bdry, reverse.xypolygon) ab <- do.call(polyclip::polyclip, append(list(a, b, "intersection", fillA="nonzero", fillB="nonzero"), p)) if(length(ab)==0) { if(fatal) stop("Intersection is empty", call.=FALSE) return(emptywindow(C)) } # ensure correct polarity totarea <- sum(unlist(lapply(ab, Area.xypolygon))) if(totarea < 0) ab <- lapply(ab, reverse.xypolygon) AB <- owin(poly=ab, check=FALSE, unitname=uname) AB <- rescue.rectangle(AB) return(AB) } ######### Result is a mask ############## # Restrict domain where possible if(Arect) A <- C if(Brect) B <- C if(Amask) A <- trim.mask(A, C) if(Bmask) B <- trim.mask(B, C) #' trap empty windows if(is.empty(A)) { if(fatal) stop("Intersection is empty", call.=FALSE) return(A) } if(is.empty(B)) { if(fatal) stop("Intersection is empty", call.=FALSE) return(B) } # Did the user specify the pixel raster? if(length(rasterinfo) > 0) { # convert to masks with specified parameters, and intersect if(Amask) { A <- do.call(as.mask, append(list(A), rasterinfo)) AB <- restrict.mask(A, B) if(fatal && is.empty(AB)) stop("Intersection is empty", call.=FALSE) return(AB) } else { B <- do.call(as.mask, append(list(B), rasterinfo)) BA <- restrict.mask(B,A) if(fatal && is.empty(BA)) stop("Intersection is empty", call.=FALSE) return(BA) } } # One mask and one rectangle? if(Arect && Bmask) return(B) if(Amask && Brect) return(A) # One mask and one polygon? if(Amask && !Bmask) { AB <- restrict.mask(A, B) if(fatal && is.empty(AB)) stop("Intersection is empty", call.=FALSE) return(AB) } if(!Amask && Bmask) { BA <- restrict.mask(B, A) if(fatal && is.empty(BA)) stop("Intersection is empty", call.=FALSE) return(BA) } # Two existing masks? if(Amask && Bmask) { # choose the finer one AB <- if(A$xstep <= B$xstep) restrict.mask(A, B) else restrict.mask(B, A) if(fatal && is.empty(AB)) stop("Intersection is empty", call.=FALSE) return(AB) } stop("Internal error: never reached") # # No existing masks. No clipping applied so far. # # Convert one window to a mask with default pixel raster, and intersect. # if(Arect) { # A <- as.mask(A) # AB <- restrict.mask(A, B) # if(fatal && is.empty(AB)) stop("Intersection is empty", call.=FALSE) # return(AB) # } else { # B <- as.mask(B) # BA <- restrict.mask(B, A) # if(fatal && is.empty(BA)) stop("Intersection is empty", call.=FALSE) # return(BA) # } } union.owin <- function(..., p) { argh <- list(...) ## weed out NULL arguments argh <- argh[!sapply(argh, is.null)] ## p is a list of arguments to polyclip::polyclip if(missing(p) || is.null(p)) p <- list() ## handle 'solist' objects argh <- expandSpecialLists(argh, "solist") rasterinfo <- list() if(length(argh) > 0) { ## arguments controlling raster info israster <- names(argh) %in% names(formals(as.mask)) if(any(israster)) { rasterinfo <- argh[israster] ## remaining arguments argh <- argh[!israster] } } ## look for window arguments isowin <- as.logical(sapply(argh, is.owin)) if(any(!isowin)) warning("Some arguments were not windows") argh <- argh[isowin] ## nwin <- length(argh) if(nwin == 0) { warning("No windows were given") return(NULL) } ## find non-empty ones if(any(isemp <- sapply(argh, is.empty))) argh <- argh[!isemp] nwin <- length(argh) if(nwin == 0) { warning("All windows were empty") return(NULL) } ## at least one window A <- argh[[1L]] if(nwin == 1) return(A) ## more than two windows if(nwin > 2) { ## check if we need polyclip somepoly <- !all(sapply(argh, is.mask)) if(somepoly) { ## determine a common set of parameters for polyclip p <- commonPolyclipArgs(do.call(boundingbox, argh), p=p) ## apply these parameters now to avoid numerical errors argh <- applyPolyclipArgs(argh, p=p) A <- argh[[1L]] } ## absorb all windows into A without rescaling nullp <- list(eps=1, x0=0, y0=0) for(i in 2:nwin) A <- do.call(union.owin, append(list(A, argh[[i]], p=nullp), rasterinfo)) if(somepoly) { ## undo rescaling A <- reversePolyclipArgs(A, p=p) } return(A) } ## Exactly two windows B <- argh[[2L]] if(identical(A, B)) return(A) ## check units if(!compatible(unitname(A), unitname(B))) warning("The two windows have incompatible units of length") uname <- harmonise(unitname(A), unitname(B), single=TRUE) ## Determine type of intersection ## Arect <- is.rectangle(A) ## Brect <- is.rectangle(B) ## Apoly <- is.polygonal(A) ## Bpoly <- is.polygonal(B) Amask <- is.mask(A) Bmask <- is.mask(B) ## Create a rectangle to contain the result C <- owinInternalRect(range(A$xrange, B$xrange), range(A$yrange, B$yrange), unitname=uname) if(!Amask && !Bmask) { ####### Result is polygonal (or rectangular) ############ a <- lapply(as.polygonal(A)$bdry, reverse.xypolygon) b <- lapply(as.polygonal(B)$bdry, reverse.xypolygon) ab <- do.call(polyclip::polyclip, append(list(a, b, "union", fillA="nonzero", fillB="nonzero"), p)) if(length(ab) == 0) return(emptywindow(C)) ## ensure correct polarity totarea <- sum(unlist(lapply(ab, Area.xypolygon))) if(totarea < 0) ab <- lapply(ab, reverse.xypolygon) AB <- owin(poly=ab, check=FALSE, unitname=uname) AB <- rescue.rectangle(AB) return(AB) } ####### Result is a mask ############ ## Determine pixel raster parameters if(length(rasterinfo) == 0) { rasterinfo <- if(Amask) list(xy=list(x=as.numeric(prolongseq(A$xcol, C$xrange)), y=as.numeric(prolongseq(A$yrow, C$yrange)))) else if(Bmask) list(xy=list(x=as.numeric(prolongseq(B$xcol, C$xrange)), y=as.numeric(prolongseq(B$yrow, C$yrange)))) else list() } ## Convert C to mask C <- do.call(as.mask, append(list(w=C), rasterinfo)) rxy <- rasterxy.mask(C) x <- rxy$x y <- rxy$y ok <- inside.owin(x, y, A) | inside.owin(x, y, B) if(all(ok)) { ## result is a rectangle C <- as.rectangle(C) } else { ## result is a mask C$m[] <- ok } return(C) } setminus.owin <- function(A, B, ..., p) { if(is.null(B)) return(A) verifyclass(B, "owin") if(is.null(A)) return(emptywindow(Frame(B))) verifyclass(A, "owin") if(is.empty(A) || is.empty(B)) return(A) if(identical(A, B)) return(emptywindow(Frame(A))) ## p is a list of arguments to polyclip::polyclip if(missing(p) || is.null(p)) p <- list() ## check units if(!compatible(unitname(A), unitname(B))) warning("The two windows have incompatible units of length") uname <- harmonise(unitname(A), unitname(B), single=TRUE) ## Determine type of arguments Arect <- is.rectangle(A) Brect <- is.rectangle(B) ## Apoly <- is.polygonal(A) ## Bpoly <- is.polygonal(B) Amask <- is.mask(A) Bmask <- is.mask(B) ## Case where A and B are both rectangular if(Arect && Brect) { if(is.subset.owin(A, B)) return(emptywindow(B)) C <- intersect.owin(A, B, fatal=FALSE) if(is.null(C) || is.empty(C)) return(A) return(complement.owin(C, A)) } ## Polygonal case if(!Amask && !Bmask) { ####### Result is polygonal ############ a <- lapply(as.polygonal(A)$bdry, reverse.xypolygon) b <- lapply(as.polygonal(B)$bdry, reverse.xypolygon) ab <- do.call(polyclip::polyclip, append(list(a, b, "minus", fillA="nonzero", fillB="nonzero"), p)) if(length(ab) == 0) return(emptywindow(B)) ## ensure correct polarity totarea <- sum(unlist(lapply(ab, Area.xypolygon))) if(totarea < 0) ab <- lapply(ab, reverse.xypolygon) AB <- owin(poly=ab, check=FALSE, unitname=uname) AB <- rescue.rectangle(AB) return(AB) } ####### Result is a mask ############ ## Determine pixel raster parameters rasterinfo <- if((length(list(...)) > 0)) list(...) else if(Amask) list(xy=list(x=A$xcol, y=A$yrow)) else if(Bmask) list(xy=list(x=B$xcol, y=B$yrow)) else list() ## Convert A to mask AB <- do.call(as.mask, append(list(w=A), rasterinfo)) rxy <- rasterxy.mask(AB) x <- rxy$x y <- rxy$y ok <- inside.owin(x, y, A) & !inside.owin(x, y, B) if(!all(ok)) AB$m[] <- ok else AB <- rescue.rectangle(AB) return(AB) } ## auxiliary functions commonPolyclipArgs <- function(..., p=NULL) { # compute a common resolution for polyclip operations # on several windows if(!is.null(p) && !is.null(p$eps) && !is.null(p$x0) && !is.null(p$y0)) return(p) bb <- boundingbox(...) xr <- bb$xrange yr <- bb$yrange eps <- p$eps %orifnull% max(diff(xr), diff(yr))/(2^31) x0 <- p$x0 %orifnull% mean(xr) y0 <- p$y0 %orifnull% mean(yr) return(list(eps=eps, x0=x0, y0=y0)) } applyPolyclipArgs <- function(x, p=NULL) { if(is.null(p)) return(x) y <- lapply(x, shift, vec=-c(p$x0, p$y0)) z <- lapply(y, scalardilate, f=1/p$eps) return(z) } reversePolyclipArgs <- function(x, p=NULL) { if(is.null(p)) return(x) y <- scalardilate(x, f=p$eps) z <- shift(y, vec=c(p$x0, p$y0)) return(z) } trim.mask <- function(M, R, tolerant=TRUE) { ## M is a mask, ## R is a rectangle ## Ensure R is a subset of bounding rectangle of M R <- owinInternalRect(intersect.ranges(M$xrange, R$xrange), intersect.ranges(M$yrange, R$yrange)) ## Deal with very thin rectangles if(tolerant) { R$xrange <- adjustthinrange(R$xrange, M$xstep, M$xrange) R$yrange <- adjustthinrange(R$yrange, M$ystep, M$yrange) } ## Extract subset of image grid yrowok <- inside.range(M$yrow, R$yrange) xcolok <- inside.range(M$xcol, R$xrange) if((ny <- sum(yrowok)) == 0 || (nx <- sum(xcolok)) == 0) return(emptywindow(R)) Z <- M Z$xrange <- R$xrange Z$yrange <- R$yrange Z$yrow <- M$yrow[yrowok] Z$xcol <- M$xcol[xcolok] Z$m <- M$m[yrowok, xcolok] if(ny < 2 || nx < 2) Z$m <- matrix(Z$m, nrow=ny, ncol=nx) Z$dim <- dim(Z$m) return(Z) } restrict.mask <- function(M, W) { ## M is a mask, W is any window stopifnot(is.mask(M)) stopifnot(inherits(W, "owin")) if(is.rectangle(W)) return(trim.mask(M, W)) M <- trim.mask(M, as.rectangle(W)) ## Determine which pixels of M are inside W rxy <- rasterxy.mask(M, drop=TRUE) x <- rxy$x y <- rxy$y ok <- inside.owin(x, y, W) Mm <- M$m Mm[Mm] <- ok M$m <- Mm return(M) } # SUBSUMED IN rmhexpand.R # expand.owin <- function(W, f=1) { # # # expand bounding box of 'win' # # by factor 'f' in **area** # if(f <= 0) # stop("f must be > 0") # if(f == 1) # return(W) # bb <- boundingbox(W) # xr <- bb$xrange # yr <- bb$yrange # fff <- (sqrt(f) - 1)/2 # Wexp <- owin(xr + fff * c(-1,1) * diff(xr), # yr + fff * c(-1,1) * diff(yr), # unitname=unitname(W)) # return(Wexp) #} trim.rectangle <- function(W, xmargin=0, ymargin=xmargin) { if(!is.rectangle(W)) stop("Internal error: tried to trim margin off non-rectangular window") xmargin <- ensure2vector(xmargin) ymargin <- ensure2vector(ymargin) if(any(xmargin < 0) || any(ymargin < 0)) stop("values of xmargin, ymargin must be nonnegative") if(sum(xmargin) > diff(W$xrange)) stop("window is too small to cut off margins of the width specified") if(sum(ymargin) > diff(W$yrange)) stop("window is too small to cut off margins of the height specified") owinInternalRect(W$xrange + c(1,-1) * xmargin, W$yrange + c(1,-1) * ymargin, unitname=unitname(W)) } grow.rectangle <- function(W, xmargin=0, ymargin=xmargin, fraction=NULL) { if(!is.null(fraction)) { fraction <- ensure2vector(fraction) if(any(fraction < 0)) stop("fraction must be non-negative") if(missing(xmargin)) xmargin <- fraction[1L] * diff(W$xrange) if(missing(ymargin)) ymargin <- fraction[2L] * diff(W$yrange) } xmargin <- ensure2vector(xmargin) ymargin <- ensure2vector(ymargin) if(any(xmargin < 0) || any(ymargin < 0)) stop("values of xmargin, ymargin must be nonnegative") owinInternalRect(W$xrange + c(-1,1) * xmargin, W$yrange + c(-1,1) * ymargin, unitname=unitname(W)) } grow.mask <- function(M, xmargin=0, ymargin=xmargin) { stopifnot(is.mask(M)) m <- as.matrix(M) Rplus <- grow.rectangle(as.rectangle(M), xmargin, ymargin) ## extend the raster xcolplus <- prolongseq(M$xcol, Rplus$xrange) yrowplus <- prolongseq(M$yrow, Rplus$yrange) mplus <- matrix(FALSE, length(yrowplus), length(xcolplus)) ## pad out the mask entries nleft <- attr(xcolplus, "nleft") nright <- attr(xcolplus, "nright") nbot <- attr(yrowplus, "nleft") ntop <- attr(yrowplus, "nright") mplus[ (nbot+1):(length(yrowplus)-ntop), (nleft+1):(length(xcolplus)-nright) ] <- m ## pack up result <- owin(xrange=Rplus$xrange, yrange=Rplus$yrange, xcol=as.numeric(xcolplus), yrow=as.numeric(yrowplus), mask=mplus, unitname=unitname(M)) return(result) } bdry.mask <- function(W) { verifyclass(W, "owin") W <- as.mask(W) m <- W$m nr <- nrow(m) nc <- ncol(m) if(!spatstat.options('Cbdrymask')) { ## old interpreted code b <- (m != rbind(FALSE, m[-nr, ])) b <- b | (m != rbind(m[-1, ], FALSE)) b <- b | (m != cbind(FALSE, m[, -nc])) b <- b | (m != cbind(m[, -1], FALSE)) } else { b <- integer(nr * nc) z <- .C(SG_bdrymask, nx = as.integer(nc), ny = as.integer(nr), m = as.integer(m), b = as.integer(b), PACKAGE="spatstat.geom") b <- matrix(as.logical(z$b), nr, nc) } W$m <- b return(W) } nvertices <- function(x, ...) { UseMethod("nvertices") } nvertices.default <- function(x, ...) { v <- vertices(x) vx <- v$x n <- if(is.null(vx)) NA else length(vx) return(n) } nvertices.owin <- function(x, ...) { if(is.empty(x)) return(0) n <- switch(x$type, rectangle=4, polygonal=sum(lengths(lapply(x$bdry, getElement, name="x"))), mask=sum(bdry.mask(x)$m)) return(n) } vertices <- function(w) { UseMethod("vertices") } vertices.owin <- function(w) { verifyclass(w, "owin") if(is.empty(w)) return(NULL) switch(w$type, rectangle={ xr <- w$xrange yr <- w$yrange vert <- list(x=xr[c(1,2,2,1)], y=yr[c(1,1,2,2)]) }, polygonal={ vert <- do.call(concatxy,w$bdry) }, mask={ bm <- bdry.mask(w)$m rxy <- rasterxy.mask(w) xx <- rxy$x yy <- rxy$y vert <- list(x=as.vector(xx[bm]), y=as.vector(yy[bm])) }) return(vert) } diameter <- function(x) { UseMethod("diameter") } diameter.owin <- function(x) { w <- as.owin(x) if(is.empty(w)) return(NULL) if(w$type == "rectangle") { d <- sqrt(diff(w$xrange)^2+diff(w$yrange)^2) } else { vert <- vertices(w) if(length(vert$x) > 3) { ## extract convex hull h <- with(vert, chull(x, y)) vert <- with(vert, list(x=x[h], y=y[h])) } d2 <- pairdist(vert, squared=TRUE) d <- sqrt(max(d2)) } return(d) } ## radius of inscribed circle inradius <- function(W) { stopifnot(is.owin(W)) if(W$type == "rectangle") { shortside(W)/2 } else max(distmap(W, invert=TRUE)) } incircle <- function(W) { # computes the largest circle contained in W verifyclass(W, "owin") if(is.empty(W)) return(NULL) if(is.rectangle(W)) { xr <- W$xrange yr <- W$yrange x0 <- mean(xr) y0 <- mean(yr) radius <- min(diff(xr), diff(yr))/2 return(list(x=x0, y=y0, r=radius)) } # compute distance to boundary D <- distmap(W, invert=TRUE) D <- D[W, drop=FALSE] # find maximum distance v <- D$v ok <- !is.na(v) Dvalues <- as.vector(v[ok]) if(length(Dvalues) == 0) return(NULL) Dmax <- max(Dvalues) # find location of maximum locn <- which.max(Dvalues) locrow <- as.vector(row(v)[ok])[locn] loccol <- as.vector(col(v)[ok])[locn] x0 <- D$xcol[loccol] y0 <- D$yrow[locrow] if(is.mask(W)) { # radius could be one pixel diameter shorter than Dmax Dpixel <- sqrt(D$xstep^2 + D$ystep^2) radius <- max(0, Dmax - Dpixel) } else radius <- Dmax return(list(x=x0, y=y0, r=radius)) } inpoint <- function(W) { # selects a point that is always inside the window. verifyclass(W, "owin") if(is.empty(W)) return(NULL) if(is.rectangle(W)) return(c(mean(W$xrange), mean(W$yrange))) if(is.polygonal(W)) { xy <- centroid.owin(W) if(inside.owin(xy$x, xy$y, W)) return(xy) } W <- as.mask(W) Mm <- W$m if(!any(Mm)) return(NULL) Mrow <- as.vector(row(Mm)[Mm]) Mcol <- as.vector(col(Mm)[Mm]) selectmiddle <- function(x) { x[ceiling(length(x)/2)] } midcol <- selectmiddle(Mcol) midrow <- selectmiddle(Mrow[Mcol==midcol]) x <- W$xcol[midcol] y <- W$yrow[midrow] return(c(x,y)) } simplify.owin <- function(W, dmin) { verifyclass(W, "owin") if(is.empty(W)) return(W) W <- as.polygonal(W) W$bdry <- lapply(W$bdry, simplify.xypolygon, dmin=dmin) return(W) } is.convex <- function(x) { verifyclass(x, "owin") if(is.empty(x)) return(TRUE) switch(x$type, rectangle={return(TRUE)}, polygonal={ b <- x$bdry if(length(b) > 1) return(FALSE) b <- b[[1L]] xx <- b$x yy <- b$y ch <- chull(xx,yy) return(length(ch) == length(xx)) }, mask={ v <- vertices(x) v <- as.ppp(v, W=as.rectangle(x)) ch <- convexhull.xy(v) edg <- edges(ch) edgedist <- nncross(v, edg, what="dist") pixdiam <- sqrt(x$xstep^2 + x$ystep^2) return(all(edgedist <= pixdiam)) }) return(as.logical(NA)) } convexhull <- function(x) { if(inherits(x, "owin")) v <- vertices(x) else if(inherits(x, "psp")) v <- endpoints.psp(x) else if(inherits(x, "ppp")) v <- x else { x <- as.owin(x) v <- vertices(x) } b <- as.rectangle(x) if(is.empty(x)) return(emptywindow(b)) ch <- convexhull.xy(v) out <- rebound.owin(ch, b) return(out) } is.empty <- function(x) { UseMethod("is.empty") } is.empty.default <- function(x) { length(x) == 0 } is.empty.owin <- function(x) { switch(x$type, rectangle=return(FALSE), polygonal=return(length(x$bdry) == 0), mask=return(!any(x$m))) return(NA) } emptywindow <- function(w) { w <- as.owin(w) out <- owin(w$xrange, w$yrange, poly=list(), unitname=unitname(w)) return(out) } discs <- function(centres, radii=marks(centres)/2, ..., separate=FALSE, mask=FALSE, trim=TRUE, delta=NULL, npoly=NULL) { stopifnot(is.ppp(centres)) n <- npoints(centres) if(n == 0) return(emptywindow(Frame(centres))) check.nvector(radii, npoints(centres), oneok=TRUE, vname="radii") stopifnot(all(radii > 0)) if(sameradius <- (length(radii) == 1)) radii <- rep(radii, npoints(centres)) if(!separate && mask) { #' compute pixel approximation M <- as.mask(Window(centres), ...) z <- .C(SG_discs2grid, nx = as.integer(M$dim[2L]), x0 = as.double(M$xcol[1L]), xstep = as.double(M$xstep), ny = as.integer(M$dim[1L]), y0 = as.double(M$yrow[1L]), ystep = as.double(M$ystep), nd = as.integer(n), xd = as.double(centres$x), yd = as.double(centres$y), rd = as.double(radii), out = as.integer(integer(prod(M$dim))), PACKAGE="spatstat.geom") M$m[] <- as.logical(z$out) return(M) } #' construct a list of discs D <- list() if(!sameradius && length(unique(radii)) > 1) { if(is.null(delta) && is.null(npoly)) { ra <- range(radii) rr <- ra[2L]/ra[1L] mm <- ceiling(128/rr) mm <- max(16, mm) ## equals 16 unless ra[2]/ra[1] < 8 delta <- 2 * pi * ra[1L]/mm } for(i in 1:n) D[[i]] <- disc(centre=centres[i], radius=radii[i], delta=delta, npoly=npoly) } else { #' congruent discs -- use 'shift' W0 <- disc(centre=c(0,0), radius=radii[1L], delta=delta, npoly=npoly) for(i in 1:n) D[[i]] <- shift(W0, vec=centres[i]) } D <- as.solist(D) #' return list of discs? if(separate) return(D) #' return union of discs W <- union.owin(D) if(trim) W <- intersect.owin(W, Window(centres)) return(W) } ## force a list of windows to have compatible pixel rasters harmonise.owin <- harmonize.owin <- function(...) { argz <- list(...) wins <- solapply(argz, as.owin) if(length(wins) < 2L) return(wins) ismask <- sapply(wins, is.mask) if(!any(ismask)) return(wins) comgrid <- do.call(commonGrid, lapply(argz, as.owin)) result <- solapply(argz, "[", i=comgrid, drop=FALSE) return(result) } spatstat.geom/R/randombasic.R0000644000176200001440000001760114667453120015666 0ustar liggesusers#' #' randombasic.R #' #' Basic random generators, needed in spatstat.geom #' #' runifrect() special case of rectangle #' rsyst() systematic random (randomly-displaced grid) #' rjitter() random perturbation #' #' $Revision: 1.18 $ $Date: 2024/09/09 01:43:21 $ simulationresult <- function(resultlist, nsim=length(resultlist), drop=TRUE, NameBase="Simulation") { if(nsim == 1 && drop) return(resultlist[[1L]]) #' return 'solist' if appropriate, otherwise 'anylist' return(as.solist(resultlist, .NameBase=NameBase, demote=TRUE)) } runifrect <- function(n, win=owin(c(0,1),c(0,1)), nsim=1, drop=TRUE) { ## no checking xr <- win$xrange yr <- win$yrange if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { x <- runif(n, min=xr[1], max=xr[2]) y <- runif(n, min=yr[1], max=yr[2]) result[[isim]] <- ppp(x, y, window=win, check=FALSE) } result <- simulationresult(result, nsim, drop) return(result) } rsyst <- function(win=square(1), nx=NULL, ny=nx, ..., dx=NULL, dy=dx, nsim=1, drop=TRUE) { if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } win <- as.owin(win) xr <- win$xrange yr <- win$yrange ## determine grid coordinates if(missing(ny)) ny <- NULL if(missing(dy)) dy <- NULL g <- xy.grid(xr, yr, nx, ny, dx, dy) x0 <- g$x0 y0 <- g$y0 dx <- g$dx dy <- g$dy ## assemble grid and randomise location xy0 <- expand.grid(x=x0, y=y0) result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { x <- xy0$x + runif(1, min = 0, max = dx) y <- xy0$y + runif(1, min = 0, max = dy) Xbox <- ppp(x, y, xr, yr, check=FALSE) ## trim to window result[[isim]] <- Xbox[win] } result <- simulationresult(result, nsim, drop) return(result) } xy.grid <- function(xr, yr, nx, ny, dx, dy) { nx.given <- !is.null(nx) ny.given <- !is.null(ny) dx.given <- !is.null(dx) dy.given <- !is.null(dy) if(nx.given && dx.given) stop("Do not give both nx and dx") if(nx.given) { stopifnot(nx >= 1) x0 <- seq(from=xr[1], to=xr[2], length.out=nx+1) dx <- diff(xr)/nx } else if(dx.given) { stopifnot(dx > 0) x0 <- seq(from=xr[1], to=xr[2], by=dx) nx <- length(x0) - 1 } else stop("Need either nx or dx") ## determine y grid if(ny.given && dy.given) stop("Do not give both ny and dy") if(ny.given) { stopifnot(ny >= 1) y0 <- seq(from=yr[1], to=yr[2], length.out=ny+1) dy <- diff(yr)/ny } else { if(is.null(dy)) dy <- dx stopifnot(dy > 0) y0 <- seq(from=yr[1], to=yr[2], by=dy) ny <- length(y0) - 1 } return(list(x0=x0, y0=y0, nx=nx, ny=ny, dx=dx, dy=dy)) } ## rjitter rjitter <- function(X, ...) { UseMethod("rjitter") } rjitter.ppp <- function(X, radius, retry=TRUE, giveup=10000, trim=FALSE, ..., nsim=1, drop=TRUE, adjust=1) { verifyclass(X, "ppp") if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } nX <- npoints(X) W <- Window(X) if(nX == 0) { result <- rep(list(X), nsim) result <- simulationresult(result, nsim, drop) return(result) } #' determine the jitter radius if(missing(radius) || is.null(radius)) { ## default: Stoyan rule of thumb bws <- 0.15/sqrt(5 * nX/area(W)) radius <- min(bws, shortside(Frame(W))) } else { ## either one radius, or a vector of radii check.nvector(radius, nX, oneok=TRUE, vname="radius") check.finite(radius, xname="radius") if(min(radius) < 0) { warning("Negative values of jitter radius were set to zero") radius <- pmax(0, radius) } } #' trim? if(isTRUE(trim)) radius <- pmin(radius, bdist.points(X)) #' adjust the jitter radius if(!missing(adjust)) { check.nvector(adjust, nX, oneok=TRUE, vname="adjust") if(min(adjust) < 0) { nbad <- sum(adjust < 0) howmanyvalues <- if(length(adjust) == 1) { "the value" } else { paste(nbad, ngettext(nbad, "value", "values")) } warning(paste("Negative sign was ignored in", howmanyvalues, "of", sQuote("adjust")), call.=FALSE) adjust <- abs(adjust) } radius <- adjust * radius } #' sameradius <- (length(radius) == 1) #' start jitterin' result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { Xshift <- X if(!retry) { ## points outside window are lost rD <- radius * sqrt(runif(nX)) aD <- runif(nX, max= 2 * pi) Xshift$x <- xx <- X$x + rD * cos(aD) Xshift$y <- yy <- X$y + rD * sin(aD) ok <- inside.owin(xx, yy, W) Xshift <- Xshift[ok] } else { ## retry = TRUE: condition on points being inside window undone <- rep.int(TRUE, nX) triesleft <- giveup while(any(undone)) { triesleft <- triesleft - 1 if(triesleft <= 0) break Y <- Xshift[undone] nY <- npoints(Y) RY <- if(sameradius) radius else radius[undone] rD <- RY * sqrt(runif(nY)) aD <- runif(nY, max= 2 * pi) xnew <- Y$x + rD * cos(aD) ynew <- Y$y + rD * sin(aD) ok <- inside.owin(xnew, ynew, W) if(any(ok)) { changed <- which(undone)[ok] Xshift$x[changed] <- xnew[ok] Xshift$y[changed] <- ynew[ok] undone[changed] <- FALSE } } attr(Xshift, "tries") <- giveup - triesleft } attr(Xshift, "radius") <- radius result[[isim]] <- Xshift } result <- simulationresult(result, nsim, drop) return(result) } ## rexplode rexplode <- function(X, ...) { UseMethod("rexplode") } rexplode.ppp <- function(X, radius, ..., nsim=1, drop=TRUE) { verifyclass(X, "ppp") if(!missing(nsim)) { check.1.integer(nsim) stopifnot(nsim >= 0) } nX <- npoints(X) W <- Window(X) if(nX == 0) { result <- rep(list(X), nsim) result <- simulationresult(result, nsim, drop) return(result) } if(missing(radius) || is.null(radius)) { ## Stoyan rule of thumb bws <- 0.15/sqrt(5 * nX/area(W)) radius <- min(bws, shortside(Frame(W))) } else { ## either one radius, or a vector of radii check.nvector(radius, nX, oneok=TRUE, vname="radius") check.finite(radius, xname="radius") if(min(radius) < 0) { warning("Negative values of jitter radius were set to zero") radius <- pmax(0, radius) } } radius <- pmin(radius, bdist.points(X)) #' U <- unmark(X) #' if(!anyDuplicated(U)) { #' no duplicated locations return(rjitter(X, radius, nsim=nsim, drop=drop, trim=TRUE)) } #' un <- uniquemap(U) #' group the duplicated locations f <- factor(un) groupindex <- as.integer(f) #' multiplicity of each group mt <- as.integer(table(f)) ngroup <- length(mt) #' do not displace points which are unique singleton <- (mt == 1) if(any(singleton)) radius[singleton[groupindex]] <- 0 #' angular spacing of displaced points in each group deltagroup <- 2 * pi/as.double(mt) deltaeach <- deltagroup[groupindex] #' serial number (0, 1, ..) of individual element within each group k <- integer(nX) split(k, f) <- lapply(split(k,f), function(z) { seq_along(z) - 1L }) #' start simulatin' Xshift <- X Xx <- X$x Xy <- X$y result <- vector(mode="list", length=nsim) for(isim in seq_len(nsim)) { #' generate random start angle for each group startanglegroup <- runif(ngroup, max=deltagroup) #' generate radius deflation factor for each group deflategroup <- sqrt(runif(ngroup)) #' periodic angle <- startanglegroup[groupindex] + deltaeach * k #' displacement rad <- radius * deflategroup[groupindex] Xshift$x <- Xx + rad * cos(angle) Xshift$y <- Xy + rad * sin(angle) result[[isim]] <- Xshift } result <- simulationresult(result, nsim, drop) return(result) } spatstat.geom/R/tess.R0000644000176200001440000011465314765164152014372 0ustar liggesusers# # tess.R # # support for tessellations # # $Revision: 1.114 $ $Date: 2025/03/15 02:34:37 $ # tess <- function(..., xgrid=NULL, ygrid=NULL, tiles=NULL, image=NULL, window=NULL, marks=NULL, keepempty=FALSE, unitname=NULL, check=TRUE) { uname <- unitname if(!is.null(window)) { window <- as.owin(window) if(is.null(uname)) uname <- unitname(window) } isrect <- !is.null(xgrid) && !is.null(ygrid) istiled <- !is.null(tiles) isimage <- !is.null(image) if(isrect + istiled + isimage != 1) stop("Must specify either (xgrid, ygrid) or tiles or img") if(isrect) { stopifnot(is.numeric(xgrid) && all(diff(xgrid) > 0)) stopifnot(is.numeric(ygrid) && all(diff(ygrid) > 0)) if(!is.null(window)) warning("Argument 'window' ignored, because xgrid, grid are given") window <- owinInternalRect(range(xgrid), range(ygrid), unitname=uname) ntiles <- (length(xgrid)-1) * (length(ygrid)-1) out <- list(type="rect", window=window, xgrid=xgrid, ygrid=ygrid, n=ntiles) } else if(istiled) { stopifnot(is.list(tiles)) if(check) { if(!all(sapply(tiles, is.owin))) stop("Tiles must be a list of owin objects") if(!is.null(uname)) { ## attach new unit name to each tile tiles <- lapply(tiles, "unitname<-", value=uname) } else { ## extract unit names from tiles, check agreement, use as unitname uu <- unique(lapply(tiles, unitname)) uu <- uu[!sapply(uu, is.null)] nun <- length(uu) if(nun > 1) stop("Tiles have inconsistent names for the unit of length") if(nun == 1) { ## use this unit name uname <- uu[[1]] if(!is.null(window)) unitname(window) <- uname } } } if(!keepempty && check) { # remove empty tiles isempty <- sapply(tiles, is.empty) if(all(isempty)) stop("All tiles are empty") if(any(isempty)) tiles <- tiles[!isempty] } ntiles <- length(tiles) nam <- names(tiles) lev <- if(!is.null(nam) && all(nzchar(nam))) nam else 1:ntiles if(is.null(window)) window <- do.call(union.owin, unname(tiles)) if(is.mask(window) || any(sapply(tiles, is.mask))) { # convert to pixel image tessellation Grid <- do.call(commonGrid, append(list(window), unname(tiles))) ima <- as.im(window, W=Grid) ima$v[] <- NA for(i in 1:ntiles) ima[tiles[[i]]] <- i ima <- ima[window, drop=FALSE] ima <- eval.im(factor(ima, levels=1:ntiles)) levels(ima) <- lev out <- list(type="image", window=window, image=ima, n=length(lev)) } else { # tile list window <- rescue.rectangle(window) out <- list(type="tiled", window=window, tiles=tiles, n=length(tiles)) } } else if(isimage) { # convert to factor valued image image <- as.im(image) if(!is.null(uname)) unitname(image) <- uname switch(image$type, logical={ # convert to factor if(keepempty) image <- eval.im(factor(image, levels=c(FALSE,TRUE))) else image <- eval.im(factor(image)) }, factor={ # eradicate unused levels if(!keepempty) image <- eval.im(factor(image)) }, { # convert to factor image <- eval.im(factor(image)) }) if(is.null(window)) window <- as.owin(image) out <- list(type="image", window=window, image=image, n=length(levels(image))) } else stop("Internal error: unrecognised format") ## add marks! if(!is.null(marks)) { mf <- markformat(marks) switch(mf, none = { marks <- NULL }, list = { marks <- hyperframe(marks=marks, row.names=NULL) }, vector = { marks <- data.frame(marks=marks, row.names=NULL) }, dataframe = , hyperframe = { row.names(marks) <- NULL } ) if(nrow(marks) != out$n) stop(paste("wrong number of marks:", nrow(marks), "should be", out$n), call.=FALSE) out$marks <- marks } class(out) <- c("tess", class(out)) return(out) } is.tess <- function(x) { inherits(x, "tess") } print.tess <- function(x, ..., brief=FALSE) { full <- !brief if(full) cat("Tessellation\n") win <- x$window switch(x$type, rect={ if(full) { unitinfo <- summary(unitname(win)) if(evenly.spaced(x$xgrid) && evenly.spaced(x$ygrid)) splat("Tiles are equal rectangles, of dimension", signif(mean(diff(x$xgrid)), 5), "x", signif(mean(diff(x$ygrid)), 5), unitinfo$plural, " ", unitinfo$explain) else splat("Tiles are unequal rectangles") } splat(length(x$xgrid)-1, "by", length(x$ygrid)-1, "grid of tiles") }, tiled={ if(full) { if(win$type == "polygonal") splat("Tiles are irregular polygons") else splat("Tiles are windows of general type") } splat(length(x$tiles), "tiles (irregular windows)") }, image={ nlev <- length(levels(x$image)) if(full) { splat("Tessellation is determined by a factor-valued image with", nlev, "levels") } else splat(nlev, "tiles (levels of a pixel image)") }) if(!is.null(marx <- x$marks)) { mf <- markformat(marx) switch(mf, none = { }, vector = { splat("Tessellation has", paste0(typeof(marx), "-valued marks")) }, list = { if(is.solist(marx)) { splat("Tessellation has a list of spatial objects as marks") } else { cls <- unique(sapply(marks, class)) if(!is.character(cls)) { splat("Tessellation has a list of marks") } else { splat("Tessellation has a list of marks of class", commasep(sQuote(cls))) } } }, dataframe = { splat("Tessellation has a data frame of marks:") nc <- ncol(marx) cn <- colnames(marx) ty <- unname(sapply(marx, typeof)) for(i in seq_len(nc)) { cat(paste0("\t$", cn[i], ":\t\t", ty[i], "\n")) } }, hyperframe = { splat("Tessellation has a hyperframe of marks:") nc <- ncol(marx) cn <- colnames(marx) cls <- sQuote(unclass(marx)$vclass) for(i in seq_len(nc)) { cat(paste0("\t$", cn[i], ":\t\t", cls[i], "\n")) } }) } if(full) print(win) invisible(NULL) } unitname.tess <- function(x) unitname(x$window) "unitname<-.tess" <- function(x, value) { unitname(x$window) <- value switch(x$type, rect={}, tiled={ x$tiles <- lapply(x$tiles, "unitname<-", value) }, image={ unitname(x$image) <- value }) return(x) } plot.tess <- local({ plotpars <- c("sub", "lty", "lwd", "cex.main", "col.main", "font.main", "cex.sub", "col.sub", "font.sub", "border") plot.tess <- function(x, ..., main, add=FALSE, show.all=!add, border=NULL, do.plot=TRUE, do.labels=!missing(labels), labels=tilenames(x), labelargs=list(), do.col=!missing(values), values=marks(x), multiplot=TRUE, col=NULL, ribargs=list()) { if(missing(main) || is.null(main)) main <- short.deparse(substitute(x)) ntiles <- x$n if(!do.col) { #' Plot tiles, with adornment y <- NULL result <- NULL bbox <- NULL need.legend <- FALSE } else { #' Fill tiles with colours determined by 'values' if(markformat(values) == "hyperframe") values <- as.data.frame(values) #' automatic warning #' Determine values associated with each tile switch(markformat(values), none = { #' no values assigned. #' default is tile name tn <- tilenames(x) values <- factor(tn, levels=tn) }, vector = { #' vector of values. #' validate length of vector check.anyvector(values, ntiles, things="tiles", vname="values") }, dataframe = { #' data frame or matrix of values. values <- as.data.frame(values) if(nrow(values) != ntiles) stop(paste("Number of rows of values =", nrow(values), "!=", ntiles, "= number of tiles"), call.=FALSE) if(multiplot && ncol(values) > 1 && !add) { #' Multiple Panel Plot result <- multi.plot.tess(x, ..., main=main, show.all=show.all, border=border, do.plot=do.plot, do.labels=do.labels, labels=labels, labelargs=labelargs, do.col=do.col, col=col, ribargs=ribargs) return(invisible(result)) } if(ncol(values) > 1) warning("Using only the first column of values") values <- values[,1] }, stop("Format of values is not understood") ) #' Single Panel Plot #' Determine colour map and plan layout (including colour ribbon) #' using rules for pixel images y <- as.im(as.function(x, values=values)) dont.complain.about(y) result <- do.call(plot.im, resolve.defaults( list(x=quote(y), do.plot=FALSE, show.all=show.all, add=add, main=main, col=col, ribargs=ribargs), list(...), list(valuesAreColours=FALSE) )) #' exit if not actually plotting if(!do.plot) return(invisible(result)) #' extract info colmap <- result bbox <- attr(result, "bbox") bbox.legend <- attr(result, "bbox.legend") need.legend <- !is.null(bbox.legend) } #' Start Plot #' initialise plot region if it is determined if(do.plot && !is.null(bbox) && !add) { plot(bbox, main=" ", type="n") add <- TRUE } switch(x$type, rect={ win <- x$window dont.complain.about(win) z <- do.call.matched(plot.owin, resolve.defaults(list(x=quote(win), main=main, add=add, show.all=show.all, do.plot=do.plot), list(...)), extrargs=plotpars) if(is.null(result)) result <- z if(do.plot) { #' actually plot if(do.col) { #' fill tiles with colours colours <- colmap(values) til <- tiles(x) for(i in seq_len(x$n)) plot(til[[i]], add=TRUE, col=colours[i], border=border, main="", ...) } else { #' draw tile boundaries only xg <- x$xgrid yg <- x$ygrid do.call.matched(segments, resolve.defaults(list(x0=xg, y0=win$yrange[1], x1=xg, y1=win$yrange[2]), list(col=border), list(...), .StripNull=TRUE)) do.call.matched(segments, resolve.defaults(list(x0=win$xrange[1], y0=yg, x1=win$xrange[2], y1=yg), list(col=border), list(...), .StripNull=TRUE)) } } }, tiled={ xwin <- x$window dont.complain.about(xwin) z <- do.call.matched(plot.owin, resolve.defaults(list(x=quote(xwin), main=main, add=add, show.all=show.all, do.plot=do.plot), list(...)), extrargs=plotpars) if(is.null(result)) result <- z if(do.plot) { #' plot each tile til <- tiles(x) if(!do.col) { #' border only lapply(til, plot.owin, ..., add=TRUE, border=border) } else { #' fill with colour colours <- colmap(values) mapply(plot.owin, x=til, col=colours, MoreArgs=list(add=TRUE, main="", border=border, ...)) } } }, image={ if(is.null(y)) y <- x$image dont.complain.about(y) result <- do.call(plot, resolve.defaults(list(quote(y), add=add, main=main, show.all=show.all, do.plot=do.plot, col=col, ribargs=ribargs), list(...), list(valuesAreColours=FALSE))) need.legend <- FALSE }) if(do.plot && do.labels) { labels <- paste(as.vector(labels)) til <- tiles(x) incircles <- lapply(til, incircle) x0 <- sapply(incircles, getElement, name="x") y0 <- sapply(incircles, getElement, name="y") do.call.matched(text.default, resolve.defaults(list(x=x0, y = y0), list(labels=labels), labelargs), funargs=graphicsPars("text")) } if(do.plot && need.legend) { #' determine position of legend xlim <- bbox.legend$xrange ylim <- bbox.legend$yrange sidecode <- attr(colmap, "side.legend") vertical <- sidecode %in% c(2,4) do.call(plot.colourmap, resolve.defaults(list(x=quote(colmap), add=TRUE, main="", xlim=xlim, ylim=ylim, side=sidecode, vertical=vertical), ribargs, list(...))) } return(invisible(result)) } multi.plot.tess <- function(x, ..., zlim=NULL, col=NULL, equal.ribbon=FALSE) { if(equal.ribbon && is.null(zlim) && !inherits(col, "colourmap")) zlim <- range(marks(x)) if(!is.null(zlim)) { result <- plot(unstack(x), ..., zlim=zlim, col=col) } else { result <- plot(unstack(x), ..., col=col) } return(invisible(result)) } plot.tess }) "[<-.tess" <- function(x, i, ..., value) { switch(x$type, rect=, tiled={ til <- tiles(x) til[i] <- value ok <- !unlist(lapply(til, is.null)) x <- tess(tiles=til[ok]) }, image={ stop("Cannot assign new values to subsets of a pixel image") }) return(x) } "[.tess" <- function(x, i, ...) { trap.extra.arguments(..., .Context="in [.tess") if(missing(i)) return(x) if(is.owin(i)) return(intersect.tess(x, i)) switch(x$type, rect=, tiled={ til <- tiles(x)[i] return(tess(tiles=til)) }, image={ img <- x$image oldlev <- levels(img) newlev <- unique(oldlev[i]) img <- eval.im(factor(img, levels=newlev)) return(tess(image=img)) }) } tiles <- function(x) { stopifnot(is.tess(x)) switch(x$type, rect={ out <- list() xg <- x$xgrid yg <- x$ygrid nx <- length(xg) - 1 ny <- length(yg) - 1 for(j in rev(seq_len(ny))) { for(i in seq_len(nx)) { winij <- owinInternalRect(xg[c(i,i+1)], yg[c(j,j+1)]) out <- append(out, list(winij)) } } }, tiled={ out <- x$tiles }, image={ out <- list() ima <- x$image lev <- levels(ima) for(i in seq_along(lev)) out[[i]] <- solutionset(ima == lev[i]) }) names(out) <- tilenames(x) out <- as.solist(out) return(out) } tiles.empty <- function(x) { stopifnot(is.tess(x)) switch(x$type, rect = { nx <- length(x$xgrid) - 1 ny <- length(x$ygrid) - 1 ans <- rep(FALSE, nx * ny) }, tiled = { ans <- sapply(x$tiles, is.empty) }, image = { ans <- (table(x$image[]) == 0) }) return(ans) } tilenames <- function(x) { UseMethod("tilenames") } tilenames.tess <- function(x) { switch(x$type, rect={ if(!is.null(x$tilenames)) { out <- x$tilenames } else { nx <- length(x$xgrid) - 1 ny <- length(x$ygrid) - 1 ij <- expand.grid(1:nx, 1:ny) out <- paste0("Tile row ", ij[,2], ", col ", ij[,1]) } }, tiled={ out <- names(x$tiles) if(sum(nzchar(out)) != x$n) out <- paste("Tile", seq_len(x$n)) }, image={ out <- levels(x$image) } ) return(as.character(out)) } "tilenames<-" <- function(x, value) { UseMethod("tilenames<-") } "tilenames<-.tess" <- function(x, value) { if(!is.null(value)) { ## validate length value <- as.character(value) nv <- length(value) switch(x$type, rect = { nx <- length(x$xgrid) - 1 ny <- length(x$ygrid) - 1 n <- nx * ny }, tiled = { n <- length(x$tiles) }, image = { n <- length(levels(x$image)) }) if(nv != n) stop("Replacement value has wrong length", paren(paste(nv, "instead of", n))) } switch(x$type, rect={ x$tilenames <- value }, tiled={ names(x$tiles) <- value }, image={ levels(x$image) <- value %orifnull% (1:n) } ) return(x) } marks.tess <- function(x, ...) { stopifnot(is.tess(x)) return(x$marks) } "marks<-.tess" <- function(x, ..., value) { stopifnot(is.tess(x)) if(!is.null(value)) { mf <- markformat(value) switch(mf, none = { value <- NULL }, list = { value <- hyperframe(marks=value, row.names=NULL) }, vector = { value <- data.frame(marks=value, row.names=NULL) }, dataframe = , hyperframe = { row.names(value) <- NULL } ) ntil <- x$n if(nrow(value) != ntil) stop(paste("replacement value for marks has wrong length:", nrow(value), "should be", ntil), call.=FALSE) } x$marks <- value return(x) } unmark.tess <- function(X) { marks(X) <- NULL; return(X) } tile.areas <- function(x) { stopifnot(is.tess(x)) switch(x$type, rect={ xg <- x$xgrid yg <- x$ygrid a <- outer(rev(diff(yg)), diff(xg), "*") a <- as.vector(t(a)) names(a) <- as.vector(t(tilenames(x))) }, tiled={ a <- as.numeric(sapply(x$tiles, area)) names(a) <- tilenames(x) }, image={ z <- x$image a <- as.numeric(table(z$v)) * z$xstep * z$ystep names(a) <- tilenames(x) }) return(a) } as.im.tess <- function(X, W=NULL, ..., eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, values=NULL) { rule.eps <- match.arg(rule.eps) ## if W is present, it may have to be converted if(!is.null(W)) { stopifnot(is.owin(W)) if(W$type != "mask") W <- as.mask(W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) } if(!is.null(values)) { if(!is.atomic(values)) stop("Argument 'values' should contain numeric, logical or factor values", call.=FALSE) if(length(values) != nobjects(X)) stop(paste("length(values) =", length(values), "!=", nobjects(X), "= number of tiles"), call.=FALSE) } switch(X$type, image={ if(is.null(values)) { ## result is factor image out <- as.im(X$image, W=W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps, na.replace=na.replace) } else { ## map tiles to 'values' out <- as.im(X$image, W=W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) out <- eval.im(values[as.integer(out)]) ## replace NA by other value if(!is.null(na.replace)) out <- as.im(out, na.replace=na.replace) } }, tiled={ if(is.null(W)) W <- as.mask(as.owin(X), eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) til <- X$tiles ntil <- length(til) nama <- names(til) if(is.null(nama) || !all(nzchar(nama))) nama <- paste(seq_len(ntil)) xy <- list(x=W$xcol, y=W$yrow) for(i in seq_len(ntil)) { indic <- as.mask(til[[i]], xy=xy) tag <- as.im(indic, value=i) if(i == 1) { out <- tag outv <- as.integer(out$v) } else { outv <- pmin.int(outv, tag$v, na.rm=TRUE) } } if(is.null(values)) { ## result is factor image outv <- factor(outv, levels=seq_len(ntil), labels=nama) } else { ## map tiles to 'values' outv <- values[outv] } if(!is.null(na.replace) && anyNA(outv)) outv[is.na(outv)] <- na.replace out <- im(outv, out$xcol, out$yrow, unitname=unitname(W)) }, rect={ out <- as.im(W %orifnull% as.rectangle(X), eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) xg <- X$xgrid yg <- X$ygrid nrows <- length(yg) - 1L ncols <- length(xg) - 1L jx <- findInterval(out$xcol, xg, rightmost.closed=TRUE) iy <- findInterval(out$yrow, yg, rightmost.closed=TRUE) M <- as.matrix(out) Jcol <- jx[col(M)] Irow <- nrows - iy[row(M)] + 1L Ktile <- as.integer(Jcol + ncols * (Irow - 1L)) if(is.null(values)) { ## result is factor image outv <- factor(Ktile, levels=seq_len(nrows * ncols)) } else { ## map tiles to 'values' outv <- values[Ktile] } if(!is.null(na.replace) && anyNA(outv)) outv[is.na(outv)] <- na.replace out <- im(outv, xcol=out$xcol, yrow=out$yrow, unitname=unitname(W)) } ) return(out) } nobjects.tess <- function(x) { switch(x$type, image = length(levels(x$image)), rect = (length(x$xgrid)-1) * (length(x$ygrid)-1), tiled = length(x$tiles)) } tileindex <- function(x, y, Z) { stopifnot(is.tess(Z)) if((missing(y) || is.null(y)) && all(c("x", "y") %in% names(x))) { y <- x$y x <- x$x } stopifnot(length(x) == length(y)) switch(Z$type, rect={ jx <- findInterval(x, Z$xgrid, rightmost.closed=TRUE) iy <- findInterval(y, Z$ygrid, rightmost.closed=TRUE) nrows <- length(Z$ygrid) - 1 ncols <- length(Z$xgrid) - 1 iy[iy < 1 | iy > nrows] <- NA jx[jx < 1 | jx > ncols] <- NA jcol <- jx irow <- nrows - iy + 1 ktile <- jcol + ncols * (irow - 1) m <- factor(ktile, levels=seq_len(nrows*ncols)) ij <- expand.grid(j=seq_len(ncols),i=seq_len(nrows)) levels(m) <- paste("Tile row ", ij$i, ", col ", ij$j, sep="") }, tiled={ n <- length(x) todo <- seq_len(n) nt <- length(Z$tiles) m <- integer(n) for(i in 1:nt) { ti <- Z$tiles[[i]] hit <- inside.owin(x[todo], y[todo], ti) if(any(hit)) { m[todo[hit]] <- i todo <- todo[!hit] } if(length(todo) == 0) break } m[m == 0] <- NA nama <- names(Z$tiles) lev <- seq_len(nt) lab <- if(!is.null(nama) && all(nzchar(nama))) nama else paste("Tile", lev) m <- factor(m, levels=lev, labels=lab) }, image={ Zim <- Z$image m <- lookup.im(Zim, x, y, naok=TRUE) if(anyNA(m)) { #' look up neighbouring pixels isna <- is.na(m) rc <- nearest.valid.pixel(x[isna], y[isna], Zim, nsearch=2) m[isna] <- Zim$v[cbind(rc$row, rc$col)] } } ) return(m) } as.tess <- function(X) { UseMethod("as.tess") } as.tess.tess <- function(X) { fields <- switch(X$type, rect={ c("xgrid", "ygrid") }, tiled={ "tiles" }, image={ "image" }, stop(paste("Unrecognised tessellation type", sQuote(X$type)))) fields <- c(c("type", "window", "n", "marks"), fields) X <- unclass(X)[fields] class(X) <- c("tess", class(X)) return(X) } as.tess.im <- function(X) { return(tess(image = X)) } as.tess.list <- function(X) { W <- lapply(X, as.owin) return(tess(tiles=W)) } as.tess.owin <- function(X) { return(tess(tiles=list(X))) } domain.tess <- Window.tess <- function(X, ...) { as.owin(X) } intersect.tess <- function(X, Y, ..., keepempty=FALSE, keepmarks=FALSE, sep="x") { X <- as.tess(X) check.1.string(sep) if(is.owin(Y)) { ## intersection of a tessellation with a window if(Y$type == "mask") { ## convert to pixel image Xtiles <- tiles(X) seqXtiles <- seq_along(Xtiles) result <- as.im(Y, value=factor(1, levels=seqXtiles)) for(i in seqXtiles) { tilei <- Xtiles[[i]] result[tilei] <- i } result <- result[Y, drop=FALSE] out <- tess(image=result, window=Y, keepempty=keepempty) if(keepmarks && !is.null(marx <- marks(X))) { if(keepempty) { marks(out) <- marx } else { #' identify non-empty tiles tab <- table(factor(result[], levels=seqXtiles)) marks(out) <- marksubset(marx, tab > 0) } } return(out) } else { ## efficient code when Y is a window, retaining names of tiles of X Ztiles <- lapply(tiles(X), intersect.owin, B=Y, ..., fatal=FALSE) isempty <- !keepempty & sapply(Ztiles, is.empty) Ztiles <- Ztiles[!isempty] Xwin <- as.owin(X) Ywin <- Y Zwin <- intersect.owin(Xwin, Ywin) out <- tess(tiles=Ztiles, window=Zwin, keepempty=keepempty) if(keepmarks) { marx <- marks(X) if(!is.null(marx)) marx <- marksubset(marx, !isempty) marks(out) <- marx } return(out) } } ## general case: intersection of two tessellations Y <- as.tess(Y) Xtiles <- tiles(X) Ytiles <- tiles(Y) Ztiles <- list() namesX <- tilenames(X) namesY <- tilenames(Y) if(keepmarks) { ## initialise the mark variables to be inherited from parent tessellations Xmarks <- marks(X) Ymarks <- marks(Y) mfX <- markformat(Xmarks) mfY <- markformat(Ymarks) gotXmarks <- (mfX != "none") gotYmarks <- (mfY != "none") if(gotXmarks && gotYmarks) { ## marks from each input will be combined as separate columns switch(mfX, vector = { Xmarks <- data.frame(Xmarks=Xmarks) }, list = { Xmarks <- hyperframe(Xmarks=Xmarks) }, hyperframe = , dataframe = { colnames(Xmarks) <- paste0("X", colnames(Xmarks)) }) switch(mfY, vector = { Ymarks <- data.frame(Ymarks=Ymarks) }, list = { Ymarks <- hyperframe(Ymarks=Ymarks) }, hyperframe = , dataframe = { colnames(Ymarks) <- paste0("Y", colnames(Ymarks)) }) ## ensure hyperframe code is dispatched where required if(is.hyperframe(Xmarks) && !is.hyperframe(Ymarks)) Ymarks <- as.hyperframe(Ymarks) if(!is.hyperframe(Xmarks) && is.hyperframe(Ymarks)) Xmarks <- as.hyperframe(Xmarks) } ## initialise if(gotXmarks || gotYmarks) { marx <- if(gotXmarks && gotYmarks) { cbind(marksubset(Xmarks, integer(0)), marksubset(Ymarks, integer(0))) } else if(gotXmarks) { marksubset(Xmarks, integer(0)) } else { marksubset(Ymarks, integer(0)) } } else keepmarks <- FALSE } ## now compute intersection tiles Xtrivial <- (length(Xtiles) == 1) for(i in seq_along(Xtiles)) { Xi <- Xtiles[[i]] Ti <- lapply(Ytiles, intersect.owin, B=Xi, ..., fatal=FALSE) keep <- keepempty | !sapply(Ti, is.empty) if(any(keep)) { Ti <- Ti[keep] names(Ti) <- if(Xtrivial) namesY[keep] else paste(namesX[i], namesY[keep], sep=sep) Ztiles <- append(Ztiles, Ti) if(keepmarks) { extra <- if(gotXmarks && gotYmarks) { cbind(marksubset(Xmarks, i), marksubset(Ymarks, keep), row.names=NULL) } else if(gotYmarks) { marksubset(Ymarks, keep) } else { marksubset(Xmarks, rep(i, sum(keep))) } marx <- rbind(marx, extra) } } } ## form tessellation object Xwin <- as.owin(X) Ywin <- as.owin(Y) Zwin <- intersect.owin(Xwin, Ywin) out <- tess(tiles=Ztiles, window=Zwin, keepempty=keepempty) if(keepmarks) marks(out) <- marx return(out) } venn.tess <- function(..., window=NULL, labels=FALSE) { argh <- list(...) nargh <- length(argh) if(nargh == 0) stop("No arguments given") iswin <- sapply(argh, is.owin) istes <- sapply(argh, is.tess) if(!all(iswin | istes)) stop("All arguments must be windows or tessellations", call.=FALSE) nama <- names(argh) if(sum(nzchar(nama)) < nargh) nama <- paste0("T", seq_len(nargh)) W <- window %orifnull% do.call(union.owin, unname(lapply(argh, as.owin))) for(i in seq_len(nargh)) { A <- argh[[i]] if(is.owin(A)) { Z <- list(A, Out=setminus.owin(W, A)) names(Z) <- paste0(c("", "not"), nama[i]) A <- tess(tiles=Z, window=W) if(labels) marks(A) <- c(TRUE, FALSE) } Y <- if(i == 1) A else intersect.tess(Y, A, keepmarks=labels) } if(labels) colnames(marks(Y)) <- nama return(Y) } bdist.tiles <- local({ vdist <- function(x,w) { z <- as.ppp(vertices(x), W=w, check=FALSE) min(bdist.points(z)) } edist <- function(x,b) { xd <- crossdist(edges(x, check=FALSE), b, type="separation") min(xd) } bdist.tiles <- function(X) { if(!is.tess(X)) stop("X must be a tessellation") W <- as.owin(X) switch(X$type, rect=, tiled={ tt <- tiles(X) if(is.convex(W)) { # distance is minimised at a tile vertex d <- sapply(tt, vdist, w=W) } else { # coerce everything to polygons W <- as.polygonal(W) tt <- lapply(tt, as.polygonal) # compute min dist from tile edges to window edges d <- sapply(tt, edist, b=edges(W)) } }, image={ Xim <- X$image # compute boundary distance for each pixel bd <- bdist.pixels(as.owin(Xim), style="image") bd <- bd[W, drop=FALSE] # split over tiles bX <- split(bd, X) # compute minimum distance over each level of factor d <- sapply(bX, function(z) { summary(z)$min }) } ) return(d) } bdist.tiles }) ## ......... geometrical transformations .................. shift.tess <- function(X, ...) { Y <- X Y$window <- wY <- shift(X$window, ...) vec <- getlastshift(wY) switch(X$type, rect={ Y$xgrid <- Y$xgrid + vec[1] Y$ygrid <- Y$ygrid + vec[2] }, tiled={ Y$tiles <- lapply(Y$tiles, shift, vec=vec) }, image = { Y$image <- shift(Y$image, vec) }) attr(Y, "lastshift") <- vec return(Y) } affine.tess <- function(X, mat=diag(c(1,1)), vec=c(0,0), ...) { Y <- X Y$window <- affine(X$window, mat=mat, vec=vec, ...) switch(Y$type, rect = { if(all(mat == diag(diag(mat)))) { ## result is rectangular Y$xgrid <- sort(mat[1,1] * X$xgrid + vec[1]) Y$ygrid <- sort(mat[2,2] * X$ygrid + vec[2]) } else { ## shear transformation; treat rectangles as general tiles Y <- tess(tiles=tiles(X), window=Y$window) Y$tiles <- lapply(Y$tiles, affine, mat=mat, vec=vec, ...) } }, tiled={ Y$tiles <- lapply(Y$tiles, affine, mat=mat, vec=vec, ...) }, image = { Y$image <- affine(Y$image, mat=mat, vec=vec, ...) }) return(Y) } reflect.tess <- function(X) { Y <- X Y$window <- reflect(Y$window) switch(X$type, rect = { Y$xgrid <- rev(- Y$xgrid) Y$ygrid <- rev(- Y$ygrid) }, tiled = { Y$tiles <- lapply(Y$tiles, reflect) }, image = { Y$image <- reflect(Y$image) }) return(Y) } flipxy.tess <- function(X) { Y <- X Y$window <- flipxy(Y$window) switch(X$type, rect = { Y$xgrid <- X$ygrid Y$ygrid <- X$xgrid }, tiled = { Y$tiles <- lapply(Y$tiles, flipxy) }, image = { Y$image <- flipxy(Y$image) }) return(Y) } scalardilate.tess <- function(X, f, ...) { Y <- X Y$window <- scalardilate(X$window, f, ...) switch(X$type, rect = { Y$xgrid <- f * Y$xgrid Y$ygrid <- f * Y$ygrid }, tiled = { Y$tiles <- lapply(Y$tiles, scalardilate, f=f, ...) }, image = { Y$image <- scalardilate(Y$image, f=f, ...) }) return(Y) } rotate.tess <- function(X, angle=pi/2, ..., centre=NULL) { if(angle %% (2 * pi) == 0) return(X) if(!is.null(centre)) { X <- shift(X, origin=centre) negorigin <- getlastshift(X) } else negorigin <- NULL Y <- X Y$window <- rotate(X$window, angle=angle, ...) switch(X$type, rect = { if(angle %% (pi/2) == 0) { ## result is rectangular co <- round(cos(angle)) si <- round(sin(angle)) Y$xgrid <- sort((if(co == 0) 0 else (co * X$xgrid)) - (if(si == 0) 0 else (si * X$ygrid))) Y$ygrid <- sort((if(si == 0) 0 else (si * X$xgrid)) + (if(co == 0) 0 else (co * X$ygrid))) } else { ## general tessellation Y <- tess(tiles=lapply(tiles(X), rotate, angle=angle, ...), window=Y$window) } }, tiled = { Y$tiles <- lapply(X$tiles, rotate, angle=angle, ...) }, image = { Y$image <- rotate(X$image, angle=angle, ...) }) if(!is.null(negorigin)) Y <- shift(Y, -negorigin) return(Y) } as.data.frame.tess <- function(x, ...) { switch(x$type, rect =, tiled = { y <- lapply(tiles(x), as.data.frame, ...) z <- mapply(assignDFcolumn, x=y, value=tilenames(x), MoreArgs=list(name="Tile", ...), SIMPLIFY=FALSE) z <- do.call(rbind, z) row.names(z) <- NULL }, image = { z <- as.data.frame(x$image, ...) if(!is.na(m <- match("value", colnames(z)))) colnames(z)[m] <- "Tile" }, { z <- NULL warning("Unrecognised type of tessellation") }) return(z) } connected.tess <- function(X, ...) { Xim <- as.im(X, ...) X <- as.tess(Xim) tilesX <- tiles(X) namesX <- names(tilesX) shards <- lapply(tilesX, connected) # list of factor images shardnames <- lapply(shards, levels) nshards <- lengths(shardnames) broken <- (nshards > 1) #' unbroken tiles keep their original tile names shardnames[!broken] <- namesX[!broken] #' shards of broken tiles are named "tilename[i] shard j" shardnames[broken] <- mapply(paste, namesX[broken], "shard", shardnames[broken], SIMPLIFY=FALSE) #' rename them shards <- mapply("levels<-", shards, shardnames, SIMPLIFY=FALSE) #' separate them shards <- lapply(lapply(shards, as.tess), tiles) shards <- unlist(shards, recursive=FALSE, use.names=FALSE) names(shards) <- unlist(shardnames) #' form tessellation result <- tess(tiles=shards, window=as.owin(Xim)) result } spatstat.geom/R/as.im.R0000644000176200001440000003337114611065351014407 0ustar liggesusers# # as.im.R # # conversion to class "im" # # $Revision: 1.62 $ $Date: 2023/05/02 04:46:11 $ # # as.im() # as.im <- function(X, ...) { UseMethod("as.im") } as.im.im <- function(X, W=NULL, ..., eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL) { X <- repair.old.factor.image(X) nopar <- is.null(eps) && is.null(dimyx) && is.null(xy) if(!nopar) rule.eps <- match.arg(rule.eps) if(is.null(W)) { if(nopar) { X <- repair.image.xycoords(X) X <- na.handle.im(X, na.replace) return(X) } # pixel raster determined by dimyx etc W <- as.mask(as.rectangle(X), eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) # invoke as.im.owin Y <- as.im(W) } else if(is.mask(W) || is.im(W) || !nopar) { #' raster information is present in { W, eps, dimyx, xy } Y <- as.im(W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) } else { #' use existing raster information in X return(X[W, drop=FALSE, tight=TRUE]) } # resample X onto raster of Y Y <- rastersample(X, Y) return(na.handle.im(Y, na.replace)) } as.im.owin <- function(X, W=NULL, ..., eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, value=1) { if(!(is.null(eps) && is.null(dimyx) && is.null(xy))) { ## raster dimensions determined by dimyx etc ## convert X to a mask rule.eps <- match.arg(rule.eps) M <- as.mask(X, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) ## convert mask to image d <- M$dim v <- matrix(value, d[1L], d[2L]) ## factor case levels(v) <- levels(value) ## outside window m <- M$m v[!m] <- if(is.null(na.replace)) NA else na.replace ## create out <- im(v, M$xcol, M$yrow, xrange=M$xrange, yrange=M$yrange, unitname=unitname(X)) return(out) } if(!is.null(W) && is.owin(W) && W$type == "mask") { # raster dimensions determined by W # convert W to zero image d <- W$dim Z <- im(matrix(0, d[1L], d[2L]), W$xcol, W$yrow, unitname=unitname(X)) # adjust values to indicator of X Z[X] <- 1 if(missing(value) && is.null(na.replace)) { # done out <- Z } else { # map {0, 1} to {na.replace, value} v <- matrix(ifelseAB(Z$v == 0, na.replace, value), d[1L], d[2L]) levels(v) <- levels(value) out <- im(v, W$xcol, W$yrow, unitname=unitname(X)) } return(out) } if(X$type == "mask") { # raster dimensions determined by X # convert X to image d <- X$dim v <- matrix(value, d[1L], d[2L]) m <- X$m v[!m] <- if(is.null(na.replace)) NA else na.replace levels(v) <- levels(value) out <- im(v, xcol=X$xcol, yrow=X$yrow, xrange=X$xrange, yrange=X$yrange, unitname=unitname(X)) return(out) } # X is not a mask. # W is either missing, or is not a mask. # Convert X to a image using default settings M <- as.mask(X) # convert mask to image d <- M$dim v <- matrix(value, d[1L], d[2L]) levels(v) <- levels(value) m <- M$m v[!m] <- if(is.null(na.replace)) NA else na.replace out <- im(v, M$xcol, M$yrow, unitname=unitname(X)) return(out) } as.im.funxy <- function(X, W=Window(X), ...) { as.im.function(X, W=W, ...) } as.im.function <- function(X, W=NULL, ..., eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, stringsAsFactors=NULL, strict=FALSE, drop=TRUE) { f <- X if(is.null(W)) stop("A window W is required") stringsAsFactors <- resolve.stringsAsFactors(stringsAsFactors) W <- as.owin(W) rule.eps <- match.arg(rule.eps) W <- as.mask(W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) m <- W$m funnywindow <- !all(m) xx <- as.vector(rasterx.mask(W)) yy <- as.vector(rastery.mask(W)) argh <- list(...) if(strict) argh <- argh[names(argh) %in% names(formals(f))] #' evaluate function value at each pixel if(!funnywindow) { values <- do.call(f, append(list(xx, yy), argh)) slices <- as.list(as.data.frame(values, stringsAsFactors=stringsAsFactors)) ns <- length(slices) } else { #' evaluate only inside window inside <- as.vector(m) values.inside <- do.call(f, append(list(xx[inside], yy[inside]), argh)) slices.inside <- as.list(as.data.frame(values.inside, stringsAsFactors=stringsAsFactors)) ns <- length(slices.inside) #' pad out msize <- length(m) slices <- vector(mode="list", length=ns) for(i in seq_len(ns)) { slice.inside.i <- slices.inside[[i]] #' create space for full matrix slice.i <- vector(mode=typeof(slice.inside.i), length=msize) if(is.factor(slice.inside.i)) slice.i <- factor(slice.i, levels=levels(slice.inside.i)) #' copy values, assigning NA outside window slice.i[inside] <- slice.inside.i slice.i[!inside] <- NA #' slices[[i]] <- slice.i } } outlist <- vector(mode="list", length=ns) nc <- length(W$xcol) nr <- length(W$yrow) for(i in seq_len(ns)) { if(nr == 1 || nc == 1) { #' exception: can't determine pixel width/height from centres mat.i <- matrix(slices[[i]], nr, nc) levels(mat.i) <- levels(slices[[i]]) out.i <- im(mat.i, xrange=W$xrange, yrange=W$yrange, unitname=unitname(W)) } else { out.i <- im(slices[[i]], W$xcol, W$yrow, unitname=unitname(W)) } outlist[[i]] <- na.handle.im(out.i, na.replace) } if(ns == 1 && drop) return(outlist[[1L]]) return(as.imlist(outlist)) } as.im.expression <- function(X, W=NULL, ...) { e <- parent.frame() f <- function(x,y, ...) eval(X, envir=list(x=x, y=y), enclos=e) as.im(f, W=W, ...) } as.im.matrix <- function(X, W=NULL, ...) { nr <- nrow(X) nc <- ncol(X) if(is.null(W)) return(im(X, ...)) W <- as.owin(W) if(W$type == "mask") { xcol <- W$xcol yrow <- W$yrow # pixel coordinate information if(length(xcol) == nc && length(yrow) == nr) return(im(X, xcol, yrow, unitname=unitname(W))) } # range information R <- as.rectangle(W) xrange <- R$xrange yrange <- R$yrange return(im(X, xrange=xrange, yrange=yrange, unitname=unitname(W))) } as.im.default <- function(X, W=NULL, ..., eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL) { rule.eps <- match.arg(rule.eps) if((is.vector(X) || is.factor(X)) && length(X) == 1) { # numerical value: interpret as constant function xvalue <- X X <- function(xx, yy, ...) { rep.int(xvalue, length(xx)) } return(as.im(X, W, ..., eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps, na.replace=na.replace)) } if(is.list(X) && checkfields(X, c("x","y","z"))) { stopifnot(is.matrix(X$z)) z <- X$z y <- X$y x <- X$x # Usual S convention as in contour.default() and image.default() # Rows of z correspond to x values. nr <- nrow(z) nc <- ncol(z) lx <- length(x) ly <- length(y) if(lx == nr + 1) x <- (x[-1L] + x[-lx])/2 else if(lx != nr) stop("length of x coordinate vector does not match number of rows of z") if(ly == nc + 1) y <- (y[-1L] + y[-ly])/2 else if(ly != nc) stop("length of y coordinate vector does not match number of columns of z") # convert to class "im" out <- im(t(z), x, y) # now apply W and dimyx if present if(is.null(W) && !(is.null(eps) && is.null(dimyx) && is.null(xy))) out <- as.im(out, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) else if(!is.null(W)) out <- as.im(out, W=W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) return(na.handle.im(out, na.replace)) } stop("Can't convert X to a pixel image") } as.im.ppp <- function(X, ...) { pixellate(X, ..., weights=NULL, zeropad=FALSE) } as.im.data.frame <- function(X, ..., step, fatal=TRUE, drop=TRUE) { if(missing(step)) { xstep <- ystep <- NULL } else { step <- ensure2vector(step) xstep <- step[1L] ystep <- step[2L] } if(ncol(X) < 3) { whinge <- "Argument 'X' must have at least 3 columns of data" if(fatal) stop(whinge) warning(whinge) return(NULL) } ## extract (x,y) coordinates mch <- matchNameOrPosition(c("x", "y", "z"), names(X)) x <- X[, mch[1L]] y <- X[, mch[2L]] z <- X[, -mch[1:2], drop=FALSE] ## unique x,y coordinates xx <- sortunique(x) yy <- sortunique(y) jj <- match(x, xx) ii <- match(y, yy) iijj <- cbind(ii, jj) ## make matrix (for incomplete x, y sequence) ok <- checkbigmatrix(length(xx), length(yy), fatal=fatal) if(!ok) return(NULL) mm <- matrix(NA, length(yy), length(xx)) ## ensure xx and yy are complete equally-spaced sequences fx <- fillseq(xx, step=xstep) fy <- fillseq(yy, step=ystep) xcol <- fx[[1L]] yrow <- fy[[1L]] ## trap very large matrices ok <- checkbigmatrix(length(xcol), length(yrow), fatal=fatal) if(!ok) return(NULL) ## mapping from xx to xcol, yy to yrow jjj <- fx[[2L]] iii <- fy[[2L]] ## make matrix for full sequence m <- matrix(NA, length(yrow), length(xcol)) ## run through columns of pixel values nz <- ncol(z) result <- vector(mode="list", length=nz) names(result) <- colnames(z) for(k in seq_len(nz)) { zk <- z[,k] mm[] <- RNA <- RelevantNA(zk) mm[iijj] <- zk m[] <- RNA m[iii,jjj] <- mm lev <- levels(zk) mo <- if(is.null(lev)) m else factor(m, levels=seq_along(lev), labels=lev) result[[k]] <- im(mat=mo, xcol=xcol, yrow=yrow) } if(nz == 1 && drop) result <- result[[1L]] return(result) } # convert to image from some other format, then do something do.as.im <- function(x, action, ..., W = NULL, eps = NULL, dimyx = NULL, xy = NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace = NULL) { rule.eps <- match.arg(rule.eps) Z <- as.im(x, W=W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps, na.replace=na.replace) Y <- do.call(action, list(Z, ...)) return(Y) } na.handle.im <- function(X, na.replace) { if(is.null(na.replace)) return(X) if(length(na.replace) != 1) stop("na.replace should be a single value") if(X$type == "factor") { lev <- levels(X) newlev <- union(lev, na.replace) if(length(newlev) > length(lev)) levels(X) <- newlev } X$v[is.na(X$v)] <- na.replace return(X) } repair.old.factor.image <- function(x) { # convert from old to new representation of factor images if(x$type != "factor") return(x) v <- x$v isold <- !is.null(lev <- attr(x, "levels")) isnew <- is.factor(v) && is.matrix(v) if(isnew) return(x) if(!isold) stop("Internal error: unrecognised format for factor-valued image") v <- factor(v, levels=lev) dim(v) <- x$dim x$v <- v return(x) } repair.image.xycoords <- function(x) { v <- x$v if(is.null(dim(v))) dim(v) <- c(length(x$yrow), length(x$xcol)) im(v, xrange=x$xrange, yrange=x$yrange, unitname=unitname(x)) } ## ...... wrangle2image ................ ## 'values' can be vector, matrix or array ## Must have the dimensions expected for 'template' ## Result is an image or imlist wrangle2image <- function(values, template) { W <- as.mask(template) template <- as.im(template) tdim <- dim(template) nt <- prod(tdim) if(!is.null(vlev <- levels(values))) { ## flatten and convert to integer if(!is.factor(values)) values <- factor(values, levels=vlev) values <- as.integer(values) } nv <- length(values) vdim <- dim(values) # may be NULL vnames <- NULL if(is.null(vdim)) { ## vector or factor of values if(nv == nt) { ## values are a flattened matrix of the right dimensions values <- matrix(values, tdim[1], tdim[2]) } else if(nv %% nt == 0) { ## values are a flattened array of the right dimensions k <- nv/nt values <- array(values, dim=c(tdim, k)) } else stop("Unable to wrangle data vector to a matrix") } else if(is.matrix(values)) { ## matrix of values if(all(vdim == tdim)) { ## values are a matrix of the desired dimensions } else if(vdim[1] == nt) { ## each column of 'values' is a flattened matrix of the desired dimensions vnames <- colnames(values) values <- array(values, dim=c(tdim, vdim[2])) } else stop("Unable to wrangle data matrix") } else if(is.array(values)) { if(length(vdim) > 3) stop("Cannot wrangle a higher dimensional array") if(all(vdim[1:2] == tdim)) { ## each slice of values is a matrix of the desired dimension vnames <- dimnames(values)[[3L]] } else stop("Unable to wrangle data array") } ## values is now a matrix or array if(is.matrix(values)) { if(!is.null(vlev)) values <- factor(values, labels=vlev) result <- im(values, xcol=template$xcol, yrow=template$yrow, xrange=template$xrange, yrange=template$yrange, unitname=unitname(template)) result <- result[W, drop=FALSE] } else { m <- dim(values)[3L] result <- vector(mode="list", length=m) for(i in seq_len(m)) { vi <- values[,,i] if(!is.null(vlev)) vi <- factor(vi, labels=vlev) Z <- im(vi, xcol=template$xcol, yrow=template$yrow, xrange=template$xrange, yrange=template$yrange, unitname=unitname(template)) result[[i]] <- Z[W, drop=FALSE] } names(result) <- vnames result <- as.solist(result) } return(result) } spatstat.geom/R/is.R0000644000176200001440000000035014611065353014004 0ustar liggesusers## is.R ## original for spatstat.geom is.lpp <- function(x) { inherits(x, "lpp") } is.linnet <- function(x) { inherits(x, "linnet") } is.fv <- function(x) { inherits(x, "fv") } is.linim <- function(x) { inherits(x, "linim") } spatstat.geom/R/rotate.R0000644000176200001440000000530314720033516014667 0ustar liggesusers# # rotate.S # # $Revision: 1.22 $ $Date: 2024/11/22 07:39:44 $ # rotxy <- function(X, angle=pi/2) { co <- cos(angle) si <- sin(angle) list(x = co * X$x - si * X$y, y = si * X$x + co * X$y) } rotxypolygon <- function(p, angle=pi/2) { p[c("x","y")] <- rotxy(p, angle=angle) # area and hole status are invariant under rotation return(p) } rotate <- function(X, ...) { UseMethod("rotate") } rotate.owin <- function(X, angle=pi/2, ..., rescue=TRUE, centre=NULL) { verifyclass(X, "owin") if(!is.null(centre)) { ## rotation about designated centre X <- shift(X, origin=centre) negorig <- getlastshift(X) } else negorig <- NULL switch(X$type, rectangle={ # convert rectangle to polygon P <- owin(X$xrange, X$yrange, poly= list(x=X$xrange[c(1,2,2,1)], y=X$yrange[c(1,1,2,2)]), unitname=unitname(X)) # call polygonal case Y <- rotate.owin(P, angle, rescue=rescue) }, polygonal={ # First rotate the polygonal boundaries bdry <- lapply(X$bdry, rotxypolygon, angle=angle) # wrap up Y <- owin(poly=bdry, check=FALSE, unitname=unitname(X)) if(rescue) Y <- rescue.rectangle(Y) }, mask={ newframe <- boundingbox(rotxy(corners(X), angle)) Y <- if(length(list(...)) > 0) as.mask(newframe, ...) else as.mask(newframe, eps=with(X, min(xstep, ystep))) pixelxy <- rasterxy.mask(Y) xybefore <- rotxy(pixelxy, -angle) Y$m[] <- with(xybefore, inside.owin(x, y, X)) Y <- intersect.owin(Y, boundingbox(Y)) if(rescue) Y <- rescue.rectangle(Y) unitname(Y) <- unitname(X) }, stop("Unrecognised window type") ) if(!is.null(negorig)) Y <- shift(Y, -negorig) return(Y) } rotate.ppp <- function(X, angle=pi/2, ..., centre=NULL) { verifyclass(X, "ppp") if(!is.null(centre)) { X <- shift(X, origin=centre) negorigin <- getlastshift(X) } else negorigin <- NULL r <- rotxy(X, angle) w <- rotate.owin(X$window, angle, ...) Y <- ppp(r$x, r$y, window=w, marks=marks(X, dfok=TRUE), check=FALSE) if(!is.null(negorigin)) Y <- shift(Y, -negorigin) return(Y) } rotate.im <- function(X, angle=pi/2, ..., centre=NULL) { if(!is.null(centre)) { X <- shift(X, origin=centre) negorigin <- getlastshift(X) } else negorigin <- NULL co <- cos(angle) si <- sin(angle) m <- matrix(c(co,si,-si,co), nrow=2, ncol=2) Y <- affine(X, mat=m) unitname(Y) <- unitname(X) if(!is.null(negorigin)) Y <- shift(Y, -negorigin) return(Y) } spatstat.geom/R/round.R0000644000176200001440000000053414632242004014515 0ustar liggesusers# # round.R # # discretisation of coordinates # # $Revision: 1.7 $ $Date: 2024/06/12 06:23:53 $ round.ppp <- round.pp3 <- round.ppx <- function(x, digits=0, ...) { coords(x) <- round(as.matrix(coords(x)), digits=digits, ...) return(x) } rounding.ppp <- rounding.pp3 <- rounding.ppx <- function(x) { rounding(as.matrix(coords(x))) } spatstat.geom/R/plot.psp.R0000644000176200001440000003200714611065352015153 0ustar liggesusers#' #' plot.psp.R #' #' plot method for segment patterns #' #' $Revision: 1.7 $ $Date: 2024/02/04 08:04:51 $ plot.psp <- function(x, ..., main, add=FALSE, show.all=!add, show.window=show.all, do.plot=TRUE, use.marks=TRUE, which.marks=1, style=c("colour", "width", "none"), col=NULL, ribbon=show.all, ribsep=0.15, ribwid=0.05, ribn=1024, scale=NULL, adjust=1, legend=TRUE, leg.side=c("right", "left", "bottom", "top"), leg.sep=0.1, leg.wid=0.1, leg.args=list(), leg.scale=1, negative.args=list(col=2)) { if(missing(main) || is.null(main)) main <- short.deparse(substitute(x)) verifyclass(x, "psp") #' n <- nsegments(x) marx <- marks(x) #' style <- match.arg(style) use.marks <- use.marks && !is.null(marx) && (n != 0) && (style != "none") #' if(use.marks && style == "width") { #' plot marks as line width if(length(dim(marx))) { check.1.integer(which.marks) marx <- marx[,which.marks] } values <- as.numeric(marx) out <- thickSegments(x, widths=values, ..., add=add, main=main, do.plot=do.plot, show.all=show.all, show.window=show.window, col=col, negative.args=negative.args, legend=legend, scale=scale, adjust=adjust, leg.side=leg.side, leg.sep=leg.sep, leg.wid=leg.wid, leg.args=leg.args, leg.scale=leg.scale) return(invisible(out)) } #' plot marks as colours, if present do.ribbon <- identical(ribbon, TRUE) && use.marks ## ## .... initialise plot; draw observation window ...... owinpars <- setdiff(graphicsPars("owin"), "col") if(!do.ribbon) { ## window of x only bb.all <- as.rectangle(as.owin(x)) if(do.plot && (!add || show.window)) { xwindow <- x$window dont.complain.about(xwindow) do.call.plotfun(plot.owin, resolve.defaults(list(x=quote(xwindow), main=if(show.all) main else "", add=add, type = if(show.window) "w" else "n", show.all=show.all), list(...)), extrargs=owinpars) } } else { ## enlarged window with room for colour ribbon ## x at left, ribbon at right bb <- as.rectangle(as.owin(x)) xwidth <- diff(bb$xrange) xheight <- diff(bb$yrange) xsize <- max(xwidth, xheight) bb.rib <- owinInternalRect(bb$xrange[2] + c(ribsep, ribsep+ribwid) * xsize, bb$yrange) bb.all <- boundingbox(bb.rib, bb) if(do.plot) { pt <- prepareTitle(main) ## establish coordinate system if(!add) do.call.plotfun(plot.owin, resolve.defaults(list(x=quote(bb.all), type="n", main=pt$blank), list(...)), extrargs=owinpars) ## now plot window of x ## with title centred on this window if(show.window) { xwindow <- x$window dont.complain.about(xwindow) do.call.plotfun(plot.owin, resolve.defaults(list(x=quote(xwindow), add=TRUE, main=main, show.all=TRUE), list(...)), extrargs=owinpars) ## title done. main <- "" } } } # plot segments if(n == 0) { result <- symbolmap() attr(result, "bbox") <- bb.all return(invisible(result)) } ## determine colours if any colmap <- NULL if(use.marks) { ## use colours marx <- as.data.frame(marx)[, which.marks] if(is.character(marx) || length(unique(marx)) == 1) marx <- factor(marx) if(is.null(col)) { ## no colour info: use default colour palette nc <- if(is.factor(marx)) { length(levels(marx)) } else { min(256, length(unique(marx))) } colfun <- spatstat.options("image.colfun") col <- colfun(nc) } ## determine colour map if(inherits(col, "colourmap")) { colmap <- colourmap } else if(is.colour(col)) { ## colour values given; create colour map if(is.factor(marx)) { lev <- levels(marx) colmap <- colourmap(col=col, inputs=factor(lev)) } else { if(!all(is.finite(marx))) warning("Some mark values are infinite or NaN or NA") colmap <- colourmap(col=col, range=range(marx, finite=TRUE)) } } else stop("Format of argument 'col' is not recognised") #' map the mark values to colours col <- colmap(marx) } ## convert to greyscale? if(spatstat.options("monochrome")) { col <- to.grey(col) colmap <- to.grey(colmap) } if(do.plot) { ## plot segments do.call.plotfun(segments, resolve.defaults(as.list(x$ends), list(...), list(col=col), .MatchNull=FALSE, .StripNull=TRUE), extrargs=names(par())) ## plot ribbon if(do.ribbon) plot(colmap, vertical=TRUE, add=TRUE, xlim=bb.rib$xrange, ylim=bb.rib$yrange) } # return colour map result <- colmap %orifnull% colourmap() attr(result, "bbox") <- bb.all return(invisible(result)) } thickSegments <- local({ ## plot segment pattern with variable widths thickSegments <- function(x, widths, ..., add=FALSE, main="", do.plot=TRUE, show.all=!add, show.window=show.all, scale=NULL, adjust=1, negative.args=list(col=2), legend=TRUE, leg.side=c("right", "left", "bottom", "top"), leg.sep=0.1, leg.wid=0.1, leg.args=list(), leg.scale=1, zlim, box=FALSE) { leg.side <- match.arg(leg.side) check.1.real(leg.scale) check.1.real(adjust) if(missing(zlim) || is.null(zlim)) { zlim <- NULL zliminfo <- list() } else { check.range(zlim) stopifnot(all(is.finite(zlim))) zliminfo <- list(zlim=zlim) } W <- Window(x) stopifnot(is.numeric(widths)) #' convert non-finite widths to zero width widths[!is.finite(widths)] <- 0 #' plan layout if(legend) { #' use layout procedure in plot.im px <- pixellate(x) dont.complain.about(px) z <- do.call(plot.im, resolve.defaults(list(quote(px), do.plot=FALSE, ribbon=TRUE), list(...), list(ribside = leg.side, ribsep = leg.sep, ribwid = leg.wid, ribargs = leg.args, ribscale = leg.scale), zliminfo, list(main=main, valuesAreColours=FALSE))) bb.all <- attr(z, "bbox") bb.leg <- attr(z, "bbox.legend") } else { bb.all <- Frame(W) bb.leg <- NULL } legend <- !is.null(bb.leg) if(legend) { #' expand plot region to accommodate text annotation in legend if(leg.side %in% c("left", "right")) { delta <- 2 * sidelengths(bb.leg)[1L] xmargin <- if(leg.side == "right") c(0, delta) else c(delta, 0) bb.all <- grow.rectangle(bb.all, xmargin=xmargin) } } #' initialise plot bb <- do.call.matched(plot.owin, resolve.defaults(list(x=quote(bb.all), type="n"), list(...), list(main=main)), extrargs="type") if(box) plot(Frame(W), add=TRUE) #' resolve graphics parameters for polygons names(negative.args) <- paste0(names(negative.args), ".neg") grafpar <- resolve.defaults(negative.args, list(...), list(col=1), .MatchNull=FALSE) #' rescale width values to a plottable range if(is.null(zlim)) zlim <- range(widths, finite=TRUE) vr <- range(0, zlim) if(is.null(scale)) { maxsize <- mean(distmap(x))/2 scale <- maxsize/max(abs(vr)) } else check.1.real(scale) phys.scale <- adjust * scale halfwidths <- phys.scale * widths/2 #' plot each segment thetaperp <- angles.psp(x) + pi/2 ends <- as.matrix(unclass(x)$ends) for(i in seq_len(nobjects(x))) { xx <- ends[i, c(1L,3L)] yy <- ends[i, c(2L,4L)] drawseg(xx, yy, rep.int(halfwidths[i], 2L), thetaperp[i], grafpar) } result <- phys.scale attr(result, "bbox") <- bb if(legend) { attr(result, "bbox.legend") <- bb.leg plotWidthMap(bb.leg = bb.leg, zlim = zlim, phys.scale = phys.scale, leg.scale = leg.scale, leg.side = leg.side, leg.args = leg.args, grafpar = grafpar) } return(invisible(result)) } drawseg <- function(xx, yy, vv, ang, pars) { ## draw polygon around segment sgn <- sign(mean(vv)) xx <- c(xx, rev(xx)) yy <- c(yy, rev(yy)) vv <- c(vv, -rev(vv)) xx <- xx + cos(ang) * vv yy <- yy + sin(ang) * vv drawSignedPoly(xx, yy, pars, sgn) invisible(NULL) } thickSegments }) drawSignedPoly <- local({ ## internal function to plot line segments for style="width" ## with sign-dependent colours, etc pNames <- c("density", "angle", "border", "col", "lty") posnames <- paste(pNames, ".pos", sep="") negnames <- paste(pNames, ".neg", sep="") redub <- function(from, to, x) { #' rename entry x$from to x$to m <- match(from, names(x)) if(any(ok <- !is.na(m))) names(x)[m[ok]] <- to[ok] return(resolve.defaults(x)) } drawSignedPoly <- function(x, y, pars, sgn) { #' plot polygon using parameters appropriate to "sign" if(sgn >= 0) { pars <- redub(posnames, pNames, pars) } else { pars <- redub(negnames, pNames, pars) } pars <- pars[names(pars) %in% pNames] if(is.null(pars$border)) pars$border <- pars$col do.call(polygon, append(list(x=x, y=y), pars)) invisible(NULL) } drawSignedPoly }) ## internal function to plot the map of pixel values to line widths plotWidthMap <- function(bb.leg, zlim, phys.scale, leg.scale, leg.side, leg.args, grafpar) { ## get graphical arguments grafpar <- resolve.defaults(leg.args, grafpar) ## set up scale of typical pixel values gvals <- leg.args$at %orifnull% prettyinside(zlim) ## corresponding widths wvals <- phys.scale * gvals ## glyph positions ng <- length(gvals) xr <- bb.leg$xrange yr <- bb.leg$yrange switch(leg.side, right = , left = { y <- seq(yr[1], yr[2], length.out=ng+1L) y <- (y[-1L] + y[-(ng+1L)])/2 for(j in 1:ng) { xx <- xr[c(1L,2L,2L,1L)] yy <- (y[j] + c(-1,1) * wvals[j]/2)[c(1L,1L,2L,2L)] drawSignedPoly(x = xx, y = yy, grafpar, sign(wvals[j])) } }, bottom = , top = { x <- seq(xr[1], xr[2], length.out=ng+1L) x <- (x[-1L] + x[-(ng+1L)])/2 for(j in 1:ng) { xx <- (x[j] + c(-1,1) * wvals[j]/2)[c(1L,1L,2L,2L)] yy <- yr[c(1L,2L,2L,1L)] drawSignedPoly(x = xx, y = yy, grafpar, sign(wvals[j])) } }) ## add text labels glabs <- signif(leg.scale * gvals, 2) textpos <- switch(leg.side, right = list(x=xr[2], y=y, pos=4), left = list(x=xr[1], y=y, pos=2), bottom = list(x=x, y=yr[1], pos=1), top = list(x=x, y=yr[2], pos=3)) textargs <- resolve.defaults(textpos, leg.args, list(labels=glabs)) do.call.matched(text, textargs, extrargs=graphicsPars("text")) return(invisible(NULL)) } spatstat.geom/R/connected.R0000644000176200001440000001634214611065351015341 0ustar liggesusers# # connected.R # # connected component transform # # $Revision: 1.29 $ $Date: 2023/07/18 03:59:12 $ # # Interpreted code for pixel images by Julian Burgos # Rewritten in C by Adrian Baddeley # # Code for point patterns by Adrian Baddeley connected <- function(X, ...) { UseMethod("connected") } connected.im <- function(X, ..., background=NA, method="C", connect=8) { if(!is.na(background)) { W <- solutionset(X != background) } else if(X$type == "logical") { W <- solutionset(X) } else { warning("Assuming background = NA, foreground = other values", call.=FALSE) W <- as.owin(X) } connected.owin(W, method=method, ..., connect=connect) } connected.owin <- function(X, ..., method="C", connect=8) { method <- pickoption("algorithm choice", method, c(C="C", interpreted="interpreted")) if(!missing(connect)) { check.1.integer(connect) if(!any(connect == c(4,8))) stop("'connect' should be 4 or 8") } # convert X to binary mask X <- as.mask(X, ...) # Y <- X$m nr <- X$dim[1L] nc <- X$dim[2L] if(method == "C") { ################ COMPILED CODE ######################### # Pad border with FALSE M <- rbind(FALSE, Y, FALSE) M <- cbind(FALSE, M, FALSE) # assign unique label to each foreground pixel L <- M L[M] <- seq_len(sum(M)) L[!M] <- 0 ## resolve labels if(typeof(L) == "double") { ## Labels are numeric (not integer) ## This can occur if raster is really large if(connect == 8) { ## 8-connected z <- .C(SG_coco8dbl, mat=as.double(t(L)), nr=as.integer(nr), nc=as.integer(nc), PACKAGE="spatstat.geom") } else { ## 4-connected z <- .C(SG_coco4dbl, mat=as.double(t(L)), nr=as.integer(nr), nc=as.integer(nc), PACKAGE="spatstat.geom") } } else { ## Labels are integer if(connect == 8) { ## 8-connected z <- .C(SG_coco8int, mat=as.integer(t(L)), nr=as.integer(nr), nc=as.integer(nc), PACKAGE="spatstat.geom") } else { ## 4-connected z <- .C(SG_coco4int, mat=as.integer(t(L)), nr=as.integer(nr), nc=as.integer(nc), PACKAGE="spatstat.geom") } } # unpack Z <- matrix(z$mat, nr+2, nc+2, byrow=TRUE) } else { ################ INTERPRETED CODE ######################### # by Julian Burgos # # Pad border with zeros padY <- rbind(0, Y, 0) padY <- cbind(0, padY, 0) # Initialise Z <- matrix(0, nrow(padY), ncol(padY)) currentlab <- 1L todo <- as.vector(t(Y)) equiv <- NULL ## extension by Adrian nprev <- as.integer(connect/2) # ........ main loop .......................... while(any(todo)){ # pick first unresolved pixel one <- which(todo)[1L] onerow <- ceiling(one/nc) onecol <- one -((onerow-1L)*nc) parow=onerow+1L # Equivalent rows & column in padded matrix pacol=onecol+1L ## Examine four previously scanned neighbors ## (use padded matrix to avoid edge issues) nbrs <- if(connect == 8) { rbind(c(parow-1L,pacol-1L), c(parow-1L,pacol), c(parow, pacol-1L), c(parow-1L,pacol+1L)) } else { rbind(c(parow-1L,pacol), c(parow, pacol-1L)) } px <- sum(padY[nbrs]) if (px==0){ # no neighbours: new component Z[parow,pacol] <- currentlab currentlab <- currentlab+1L todo[one] <- FALSE } else if(px==1L) { # one neighbour: assign existing label labs <- unique(Z[nbrs], na.rm=TRUE) labs <- labs[labs != 0] Z[parow,pacol] <- labs[1L] currentlab <- max(Z)+1L todo[one] <- FALSE } else { # more than one neighbour: possible merger of labels labs <- unique(Z[nbrs], na.rm=TRUE) labs <- labs[labs != 0] labs <- sort(labs) equiv <- rbind(equiv,c(labs,rep.int(0,times=nprev-length(labs)))) Z[parow,pacol] <- labs[1L] currentlab <- max(Z)+1L todo[one] <- FALSE } } # ........... end of loop ............ # Resolve equivalences ................ if(length(equiv)>1L){ merges <- (equiv[,2L] > 1L) nmerge <- sum(merges) if(nmerge==1L) equiv <- equiv[which(merges), , drop=FALSE] else if(nmerge > 1L) { relevant <- (equiv[,2L] > 0) equiv <- equiv[relevant, , drop=FALSE] equiv <- equiv[fave.order(equiv[,1L]),] } for (i in 1:nrow(equiv)){ current <- equiv[i, 1L] for (j in 2:nprev){ twin <- equiv[i,j] if (twin>0){ # Change labels matrix Z[which(Z==twin)] <- current # Update equivalence table equiv[which(equiv==twin)] <- current } } } } } ########### COMMON CODE ############################ # Renumber labels sequentially mapped <- (Z != 0) usedlabs <- sortunique(as.vector(Z[mapped])) nlabs <- length(usedlabs) labtable <- cumsum(seq_len(max(usedlabs)) %in% usedlabs) Z[mapped] <- labtable[Z[mapped]] # banish zeroes Z[!mapped] <- NA # strip borders Z <- Z[2:(nrow(Z)-1L),2:(ncol(Z)-1L)] # dress up Z <- im(factor(Z, levels=1:nlabs), xcol=X$xcol, yrow=X$yrow, unitname=unitname(X)) return(Z) } connected.ppp <- connected.pp3 <- function(X, R, ...) { methodname <- if(is.ppp(X)) "connected.ppp" else if(is.pp3(X)) "connected.pp3" else stopifnot(is.ppp(X) || is.pp3(X)) check.1.real(R, paste("In", methodname)) stopifnot(R >= 0) internal <- resolve.1.default("internal", list(...), list(internal=FALSE)) nv <- npoints(X) cl <- closepairs(X, R, what="indices") lab0 <- cocoEngine(nv, cl$i - 1L, cl$j - 1L, methodname) if(internal) return(lab0) lab <- lab0 + 1L # Renumber labels sequentially lab <- as.integer(factor(lab)) # Convert labels to factor lab <- factor(lab) # Apply to points Y <- X %mark% lab return(Y) } cocoEngine <- function(nv, ie, je, algoname="connectedness algorithm") { #' no checks #' ie, je are 0-based indices (range between 0 and nv-1) ne <- length(ie) zz <- .C(SG_cocoGraph, nv=as.integer(nv), ne=as.integer(ne), ie=as.integer(ie), je=as.integer(je), label=as.integer(integer(nv)), status=as.integer(integer(1L)), PACKAGE="spatstat.geom") if(zz$status != 0) stop(paste("Internal error:", algoname, "did not converge"), call.=FALSE) return(zz$label) } # ................................................. is.connected <- function(X, ...) { UseMethod("is.connected") } is.connected.default <- function(X, ...) { y <- connected(X, ...) npieces <- length(levels(y)) if(npieces == 0) stop("Unable to determine connectedness") return(npieces == 1) } is.connected.ppp <- function(X, R, ...) { lab <- connected(X, R, internal=TRUE) npieces <- length(unique(lab)) return(npieces == 1) } spatstat.geom/R/polartess.R0000644000176200001440000000637414611065352015420 0ustar liggesusers#' #' polartess.R #' #' Tessellation using polar coordinates #' #' $Revision: 1.4 $ $Date: 2019/03/16 05:36:40 $ polartess <- function(W, ..., nradial=NULL, nangular=NULL, radii=NULL, angles=NULL, origin=NULL, sep="x") { trap.extra.arguments(...) W <- as.owin(W) if(!is.null(origin)) { origin <- interpretAsOrigin(origin, W) W <- shift(W, -origin) } V <- vertices(Frame(W)) rmax <- sqrt(max(V$x^2 + V$y^2)) if(!is.null(radii)) { if(!is.null(nradial)) warning("nradial ignored because radii were specified") radii <- as.numeric(radii) stopifnot(length(radii) >= 2) stopifnot(all(radii >= 0)) if(sum(is.infinite(radii)) > 1 || !all(diff(radii) > 0)) stop("radii should be increasing") radnames <- paste(signif(radii, 4)) radii[is.infinite(radii)] <- 1.01 * rmax rmax <- max(radii) nradial <- length(radii) - 1L } else if(!is.null(nradial)) { check.1.integer(nradial) radii <- seq(0, rmax, length.out=nradial+1L) radnames <- paste(signif(radii, 4)) } nradii <- length(radii) if(!is.null(angles)) { if(!is.null(nangular)) warning("nangular ignored because angles were specified") angles <- as.numeric(angles) stopifnot(length(angles) >= 2) if(!all(diff(angles) > 0)) stop("angles should be increasing") if(diff(range(angles)) > 2 * pi + .Machine$double.eps) stop("The range of angles must not exceed 2 * pi") nangular <- length(angles) - 1L } else if(!is.null(nangular)) { check.1.integer(nangular) angles <- seq(0, 2*pi, length.out=nangular+1L) } nangles <- length(angles) #' build tessellations result <- as.tess(W) DD <- Dmax <- disc(rmax) if(!is.null(radii)) { rmin <- radii[1] if(rmin > 0) DD <- setminus.owin(DD, disc(rmin)) Dlist <- lapply(radii[radii > 0], disc) if(rmin == 0) Dlist <- append(list(NULL), Dlist) Tlist <- list() for(i in 1:nradial) Tlist <- append(Tlist, list(setminus.owin(Dlist[[i+1]], Dlist[[i]]))) names(Tlist) <- paste0("[", radnames[-nradii], ", ", radnames[-1L], c(rep(")", nradial-1L), "]")) Rtess <- tess(tiles=Tlist, window=DD) result <- intersect.tess(result, Rtess, sep=sep) } if(!is.null(angles)) { Tlist <- list() aa <- seq(min(angles), max(angles), length.out=256) aa <- sort(c(aa, angles)) xx <- rmax * cos(aa) yy <- rmax * sin(aa) for(i in 1:nangular) { jj <- (aa >= angles[i]) & (aa <= angles[i+1L]) Tlist[[i]] <- owin(poly=list(x=c(0, xx[jj]), y=c(0, yy[jj]))) } angnames <- lapply(angles/pi, simplenumber, unit="pi", multiply="") unknown <- sapply(angnames, is.null) angnames[unknown] <- paste(signif((angles/pi)[unknown], 4), "pi") angnames <- unlist(angnames) names(Tlist) <- paste0("[", angnames[-nangles], ", ", angnames[-1L], c(rep(")", nangular-1L), "]")) gap <- abs(1 - diff(range(angles))/(2*pi)) DDD <- if(gap < 0.01) Dmax else owin(poly=list(x=c(0, xx), y=c(0,yy))) Atess <- tess(tiles=Tlist, window=DDD) result <- intersect.tess(result, Atess, sep=sep) } if(!is.null(origin)) result <- shift(result, vec=origin) return(result) } spatstat.geom/R/unique.ppp.R0000644000176200001440000001352514636754420015514 0ustar liggesusers# # unique.ppp.R # # $Revision: 1.40 $ $Date: 2024/06/26 08:53:35 $ # # Methods for 'multiplicity' co-authored by Sebastian Meyer # Copyright 2013 Adrian Baddeley and Sebastian Meyer unique.ppp <- function(x, ..., warn=FALSE) { verifyclass(x, "ppp") dupe <- duplicated.ppp(x, ...) if(!any(dupe)) return(x) if(warn) warning(paste(sum(dupe), "duplicated points were removed"), call.=FALSE) return(x[!dupe]) } duplicated.ppp <- function(x, ..., rule=c("spatstat", "deldir", "unmark")) { verifyclass(x, "ppp") rule <- match.arg(rule) if(rule == "deldir") return(deldir::duplicatedxy(x)) n <- npoints(x) xloc <- unmark(x) if(!anyDuplicated(xloc)) return(logical(n)) # i.e. vector of FALSE if(rule == "unmark") x <- xloc switch(markformat(x), none = { #' unmarked points u <- uniquemap(x) result <- (u != seq_along(u)) }, vector = { #' marked points - convert mark to integer m <- marks(x) if(is.factor(m)) { marks(x) <- as.integer(m) } else { um <- unique(m) marks(x) <- match(m, um) } result <- duplicated(as.data.frame(x)) }, dataframe = { result <- duplicated(as.data.frame(x)) }, # the following are currently not supported hyperframe = { result <- duplicated(as.data.frame(x)) }, list = { result <- duplicated(as.data.frame(as.hyperframe(x))) }, stop(paste("Unknown mark type", sQuote(markformat(x)))) ) return(result) } anyDuplicated.ppp <- function(x, ...) { #' first check duplication of coordinates using fast code n <- npoints(x) if(n <= 1) return(FALSE) xx <- x$x yy <- x$y o <- order(xx, seq_len(n)) anydupXY <- .C(SG_anydupxy, n=as.integer(n), x=as.double(xx[o]), y=as.double(yy[o]), anydup=as.integer(integer(1)), PACKAGE="spatstat.geom")$anydup anydupXY && (!is.marked(x) || anyDuplicated(as.data.frame(x), ...)) } ## .......... multiplicity ............. multiplicity <- function(x) { UseMethod("multiplicity") } multiplicity.ppp <- function(x) { verifyclass(x, "ppp") np <- npoints(x) if(np == 0) return(integer(0)) cl <- closepairs(x, 0, what="indices") I <- cl$i J <- cl$j if(length(I) == 0) return(rep.int(1L, np)) switch(markformat(x), none = { }, vector = { marx <- as.data.frame(marks(x)) agree <- IdenticalRows(I, J, marx) I <- I[agree] J <- J[agree] }, dataframe = { marx <- marks(x) agree <- IdenticalRows(I, J, marx) I <- I[agree] J <- J[agree] }, hyperframe = { marx <- as.data.frame(marks(x)) # possibly discards columns agree <- IdenticalRows(I, J, marx) I <- I[agree] J <- J[agree] }, list = stop("Not implemented for lists of marks") ) if(length(I) == 0) return(rep.int(1L, np)) JbyI <- split(J, factor(I, levels=1:np)) result <- 1 + lengths(JbyI) return(result) } multiplicity.data.frame <- function (x) { if(all(unlist(lapply(x, is.numeric)))) return(multiplicityNumeric(as.matrix(x))) ## result template (vector of 1's) result <- setNames(rep.int(1L, nrow(x)), rownames(x)) ## check for duplicates (works for data frames, arrays and vectors) ## CAVE: comparisons are based on a character representation of x if (!any(dup <- duplicated(x))) return(result) ux <- x[!dup, , drop=FALSE] dx <- x[dup, , drop=FALSE] nu <- nrow(ux) nd <- nrow(dx) hit <- outer(seq_len(nu), seq_len(nd), IdenticalRows, a=ux, b=dx) counts <- as.integer(1L + .rowSums(hit, nu, nd)) result[!dup] <- counts dumap <- apply(hit, 2, match, x=TRUE) # equivalent to min(which(z)) result[dup] <- counts[dumap] return(result) } ### multiplicity method for NUMERIC arrays, data frames, and vectors ### This implementation is simply based on checking for dist(x)==0 multiplicityNumeric <- function(x) { if (anyDuplicated(x)) { distmat <- as.matrix(dist(x, method="manhattan")) # faster than euclid. result <- as.integer(rowSums(distmat == 0)) # labels are kept if(is.null(names(result))) names(result) <- seq_along(result) } else { # -> vector of 1's nx <- NROW(x) labels <- if (length(dim(x))) rownames(x) else names(x) if (is.null(labels)) labels <- seq_len(nx) result <- setNames(rep.int(1L, nx), labels) } return(result) } ### multiplicity method for arrays, data frames, and vectors (including lists) ### It also works for non-numeric data, since it is based on duplicated(). multiplicity.default <- function (x) { if(is.numeric(x)) return(multiplicityNumeric(x)) nx <- NROW(x) # also works for a vector x ## result template (vector of 1's) labels <- if (length(dim(x))) rownames(x) else names(x) if (is.null(labels)) labels <- seq_len(nx) result <- setNames(rep.int(1L, nx), labels) ## check for duplicates (works for data frames, arrays and vectors) ## CAVE: comparisons are based on a character representation of x if (!any(dup <- duplicated(x))) return(result) ## convert x to a matrix for IdenticalRows() x <- as.matrix(x) dimnames(x) <- NULL # discard any names! ux <- x[!dup, , drop=FALSE] dx <- x[dup, , drop=FALSE] nu <- nrow(ux) nd <- nrow(dx) hit <- outer(seq_len(nu), seq_len(nd), IdenticalRows, a=ux, b=dx) counts <- as.integer(1L + .rowSums(hit, nu, nd)) dumap <- apply(hit, 2, match, x=TRUE) # was: function(z) min(which(z))) result[!dup] <- counts result[dup] <- counts[dumap] return(result) } spatstat.geom/R/pspcross.R0000644000176200001440000002121214611065352015244 0ustar liggesusers# # pspcross.R # # Intersections of line segments # # $Revision: 1.29 $ $Date: 2022/05/21 09:52:11 $ # # crossing.psp <- function(A,B,fatal=TRUE,details=FALSE) { verifyclass(A, "psp") verifyclass(B, "psp") # first check for intersection of windows ABW <- intersect.owin(A$window, B$window, fatal=fatal) if(is.null(ABW)) return(NULL) eps <- .Machine$double.eps na <- A$n eA <- A$ends x0a <- eA$x0 y0a <- eA$y0 dxa <- eA$x1 - eA$x0 dya <- eA$y1 - eA$y0 nb <- B$n eB <- B$ends x0b <- eB$x0 y0b <- eB$y0 dxb <- eB$x1 - eB$x0 dyb <- eB$y1 - eB$y0 useCall <- spatstat.options("crossing.psp.useCall") if(!useCall) { ## old C routine out <- .C(SG_xysegint, na=as.integer(na), x0a=as.double(x0a), y0a=as.double(y0a), dxa=as.double(dxa), dya=as.double(dya), nb=as.integer(nb), x0b=as.double(x0b), y0b=as.double(y0b), dxb=as.double(dxb), dyb=as.double(dyb), eps=as.double(eps), xx=as.double(numeric(na * nb)), yy=as.double(numeric(na * nb)), ta=as.double(numeric(na * nb)), tb=as.double(numeric(na * nb)), ok=as.integer(integer(na * nb)), PACKAGE="spatstat.geom") ok <- (matrix(out$ok, na, nb) != 0) xx <- matrix(out$xx, na, nb) yy <- matrix(out$yy, na, nb) xx <- as.vector(xx[ok]) yy <- as.vector(yy[ok]) if(details) { ia <- as.vector(row(ok)[ok]) jb <- as.vector(col(ok)[ok]) ta <- as.vector(matrix(out$ta, na, nb)[ok]) tb <- as.vector(matrix(out$tb, na, nb)[ok]) } } else { # new storage.mode(x0a) <- storage.mode(y0a) <- "double" storage.mode(dxa) <- storage.mode(dya) <- "double" storage.mode(x0b) <- storage.mode(y0b) <- "double" storage.mode(dxb) <- storage.mode(dyb) <- "double" storage.mode(eps) <- "double" out <- .Call(SG_Cxysegint, x0a, y0a, dxa, dya, x0b, y0b, dxb, dyb, eps, PACKAGE="spatstat.geom") xx <- out[[5]] yy <- out[[6]] if(details) { ia <- out[[1L]] + 1L jb <- out[[2L]] + 1L ta <- out[[3L]] tb <- out[[4L]] } } result <- ppp(xx, yy, window=ABW, check=FALSE) if(details) marks(result) <- data.frame(iA=ia, jB=jb, tA=ta, tB=tb) return(result) } test.crossing.psp <- function(A,B) { # return logical matrix specifying whether A[i] and B[j] cross verifyclass(A, "psp") verifyclass(B, "psp") eps <- .Machine$double.eps na <- A$n eA <- A$ends x0a <- eA$x0 y0a <- eA$y0 dxa <- eA$x1 - eA$x0 dya <- eA$y1 - eA$y0 nb <- B$n eB <- B$ends x0b <- eB$x0 y0b <- eB$y0 dxb <- eB$x1 - eB$x0 dyb <- eB$y1 - eB$y0 out <- .C(SG_xysi, na=as.integer(na), x0a=as.double(x0a), y0a=as.double(y0a), dxa=as.double(dxa), dya=as.double(dya), nb=as.integer(nb), x0b=as.double(x0b), y0b=as.double(y0b), dxb=as.double(dxb), dyb=as.double(dyb), eps=as.double(eps), ok=as.integer(integer(na * nb)), PACKAGE="spatstat.geom") hit <- (matrix(out$ok, na, nb) != 0) return(hit) } anycrossing.psp <- function(A,B) { # equivalent to: any(test.crossing.psp(A,B)) # Test whether two psp objects have at least one crossing point verifyclass(A, "psp") verifyclass(B, "psp") eps <- .Machine$double.eps na <- A$n eA <- A$ends x0a <- eA$x0 y0a <- eA$y0 dxa <- eA$x1 - eA$x0 dya <- eA$y1 - eA$y0 nb <- B$n eB <- B$ends x0b <- eB$x0 y0b <- eB$y0 dxb <- eB$x1 - eB$x0 dyb <- eB$y1 - eB$y0 out <- .C(SG_xysiANY, na=as.integer(na), x0a=as.double(x0a), y0a=as.double(y0a), dxa=as.double(dxa), dya=as.double(dya), nb=as.integer(nb), x0b=as.double(x0b), y0b=as.double(y0b), dxb=as.double(dxb), dyb=as.double(dyb), eps=as.double(eps), ok=as.integer(integer(1L)), PACKAGE="spatstat.geom") hit <- (out$ok != 0) return(hit) } selfcrossing.psp <- function(A) { verifyclass(A, "psp") eps <- .Machine$double.eps n <- A$n eA <- A$ends x0 <- eA$x0 y0 <- eA$y0 dx <- eA$x1 - eA$x0 dy <- eA$y1 - eA$y0 useCall <- spatstat.options("selfcrossing.psp.useCall") if(!useCall) { ## old C routine out <- .C(SG_xysegXint, n=as.integer(n), x0=as.double(x0), y0=as.double(y0), dx=as.double(dx), dy=as.double(dy), eps=as.double(eps), xx=as.double(numeric(n^2)), yy=as.double(numeric(n^2)), ti=as.double(numeric(n^2)), tj=as.double(numeric(n^2)), ok=as.integer(integer(n^2)), PACKAGE="spatstat.geom") ok <- (matrix(out$ok, n, n) != 0) xx <- matrix(out$xx, n, n) yy <- matrix(out$yy, n, n) xx <- as.vector(xx[ok]) yy <- as.vector(yy[ok]) } else { # new storage.mode(x0) <- storage.mode(y0) <- "double" storage.mode(dx) <- storage.mode(dy) <- "double" storage.mode(eps) <- "double" out <- .Call(SG_CxysegXint, x0, y0, dx, dy, eps, PACKAGE="spatstat.geom") xx <- out[[5L]] yy <- out[[6L]] } result <- ppp(xx, yy, window=A$window, check=FALSE) return(result) } test.selfcrossing.psp <- function(A) { verifyclass(A, "psp") eps <- .Machine$double.eps n <- A$n eA <- A$ends x0 <- eA$x0 y0 <- eA$y0 dx <- eA$x1 - eA$x0 dy <- eA$y1 - eA$y0 out <- .C(SG_xysxi, na=as.integer(n), x0=as.double(x0), y0=as.double(y0), dx=as.double(dx), dy=as.double(dy), eps=as.double(eps), ok=as.integer(integer(n*n)), PACKAGE="spatstat.geom") hit <- (matrix(out$ok, n, n) != 0) return(hit) } selfcut.psp <- function(A, ..., eps) { stopifnot(is.psp(A)) n <- A$n eA <- A$ends x0 <- eA$x0 y0 <- eA$y0 x1 <- eA$x1 y1 <- eA$y1 dx <- x1 - x0 dy <- y1 - y0 if(missing(eps) || is.null(eps)) { eps <- sqrt(.Machine$double.eps) * diameter(Frame(A)) } else { check.1.real(eps) stopifnot(eps >= 0) } ## identify self-crossings eps <- .Machine$double.eps storage.mode(x0) <- storage.mode(y0) <- "double" storage.mode(dx) <- storage.mode(dy) <- "double" storage.mode(eps) <- "double" zz <- .Call(SG_CxysegXint, x0, y0, dx, dy, eps, PACKAGE="spatstat.geom") if(length(zz[[1]]) == 0) { ## no dissection required attr(A, "camefrom") <- seq_len(n) return(A) } ## names(zz) <- c("i", "j", "ti", "tj", "x", "y") icross <- zz$i + 1L jcross <- zz$j + 1L ticross <- zz$ti tjcross <- zz$tj xcross <- zz$x ycross <- zz$y ## which segments are split... gone <- unique(c(icross, jcross)) ## ... and which are not retained <- setdiff(seq_len(n), gone) ## initialise result ## start with all segments which are retained x0out <- x0[retained] y0out <- y0[retained] x1out <- x1[retained] y1out <- y1[retained] camefrom <- retained ## cut each segment using the *provided* values of x,y for(ii in gone) { ## assemble cuts through segment ii imatch <- which(icross == ii) jmatch <- which(jcross == ii) ijmatch <- c(imatch, jmatch) tt <- c(ticross[imatch], tjcross[jmatch]) xx <- xcross[ijmatch] yy <- ycross[ijmatch] # discard T-junctions ok <- (tt > 0 & tt < 1) tt <- tt[ok] xx <- xx[ok] yy <- yy[ok] # order the pieces ord <- order(tt) xx <- xx[ord] yy <- yy[ord] ## add endpoints of old segment xnew <- c(x0[ii], xx, x1[ii]) ynew <- c(y0[ii], yy, y1[ii]) ## append to result m <- length(xnew) x0out <- c(x0out, xnew[-m]) y0out <- c(y0out, ynew[-m]) x1out <- c(x1out, xnew[-1L]) y1out <- c(y1out, ynew[-1L]) camefrom <- c(camefrom, rep(ii, m-1L)) } marx <- marks(A) marxout <- if(is.null(marx)) NULL else as.data.frame(marx)[camefrom, , drop=FALSE] Y <- psp(x0out, y0out, x1out, y1out, window=Window(A), marks=marxout, check=FALSE) if(eps > 0) { ok <- (lengths_psp(Y) > eps) if(!all(ok)) { Y <- Y[ok] camefrom <- camefrom[ok] } } attr(Y, "camefrom") <- camefrom return(Y) } spatstat.geom/R/images.R0000644000176200001440000012046714611065352014651 0ustar liggesusers# # images.R # # $Revision: 1.180 $ $Date: 2023/11/04 04:39:23 $ # # The class "im" of raster images # # im() object creator # # is.im() tests class membership # # rasterx.im(), rastery.im() # raster X and Y coordinates # # nearest.pixel() # lookup.im() # facilities for looking up pixel values # ################################################################ ######## basic support for class "im" ################################################################ # # creator im <- function(mat, xcol=seq_len(ncol(mat)), yrow=seq_len(nrow(mat)), xrange=NULL, yrange=NULL, unitname=NULL) { typ <- typeof(mat) if(typ == "double") typ <- "real" miss.xcol <- missing(xcol) miss.yrow <- missing(yrow) # determine dimensions if(!is.null(dim(mat))) { nr <- nrow(mat) nc <- ncol(mat) if(is.na(nc)) { #' handle one-dimensional tables nc <- 1 nr <- length(mat) if(missing(xcol)) xcol <- seq_len(nc) } if(length(xcol) != nc) stop("Length of xcol does not match ncol(mat)") if(length(yrow) != nr) stop("Length of yrow does not match nrow(mat)") } else { if(miss.xcol || miss.yrow) stop(paste(sQuote("mat"), "is not a matrix and I can't guess its dimensions")) stopifnot(length(mat) == length(xcol) * length(yrow)) nc <- length(xcol) nr <- length(yrow) } # deal with factor case if(is.factor(mat)) { typ <- "factor" } else if(!is.null(lev <- levels(mat))) { typ <- "factor" mat <- factor(mat, levels=lev) } # Ensure 'mat' is a matrix (without destroying factor information) if(!is.matrix(mat)) dim(mat) <- c(nr, nc) # set up coordinates if((miss.xcol || length(xcol) <= 1) && !is.null(xrange) ) { # use 'xrange' xstep <- diff(xrange)/nc xcol <- seq(from=xrange[1L] + xstep/2, to=xrange[2L] - xstep/2, length.out=nc) } else if(length(xcol) > 1) { # use 'xcol' # ensure spacing is constant xcol <- seq(from=min(xcol), to=max(xcol), length.out=length(xcol)) xstep <- diff(xcol)[1L] xrange <- range(xcol) + c(-1,1) * xstep/2 } else stop("Cannot determine pixel width") if((miss.yrow || length(yrow) <= 1) && !is.null(yrange)) { # use 'yrange' ystep <- diff(yrange)/nr yrow <- seq(from=yrange[1L] + ystep/2, to=yrange[2L] - ystep/2, length.out=nr) } else if(length(yrow) > 1) { # use 'yrow' # ensure spacing is constant yrow <- seq(from=min(yrow), to=max(yrow), length.out=length(yrow)) ystep <- diff(yrow)[1L] yrange <- range(yrow) + c(-1,1) * ystep/2 } else stop("Cannot determine pixel height") unitname <- as.unitname(unitname) out <- list(v = mat, dim = c(nr, nc), xrange = xrange, yrange = yrange, xstep = xstep, ystep = ystep, xcol = xcol, yrow = yrow, type = typ, units = unitname) class(out) <- "im" return(out) } is.im <- function(x) { inherits(x,"im") } levels.im <- function(x) { levels(x$v) } "levels<-.im" <- function(x, value) { if(x$type != "factor") stop("image is not factor-valued") levels(x$v) <- value x } ################################################################ ######## methods for class "im" ################################################################ shift.im <- function(X, vec=c(0,0), ..., origin=NULL) { verifyclass(X, "im") if(!is.null(origin)) { if(!missing(vec)) warning("argument vec ignored; argument origin has precedence") locn <- interpretAsOrigin(origin, Window(X)) vec <- -locn } vec <- as2vector(vec) X$xrange <- X$xrange + vec[1L] X$yrange <- X$yrange + vec[2L] X$xcol <- X$xcol + vec[1L] X$yrow <- X$yrow + vec[2L] attr(X, "lastshift") <- vec return(X) } "Frame<-.im" <- function(X, value) { stopifnot(is.rectangle(value)) if(!is.subset.owin(value, Frame(X))) { ## first expand X <- X[value, drop=FALSE] } X[value, drop=TRUE] } "[.im" <- local({ disjoint <- function(r, s) { (r[2L] < s[1L]) || (r[1L] > s[2L]) } clip <- function(r, s) { c(max(r[1L],s[1L]), min(r[2L],s[2L])) } inrange <- function(x, r) { (x >= r[1L]) & (x <= r[2L]) } Extract.im <- function(x, i, j, ..., drop=TRUE, tight=FALSE, raster=NULL, rescue=is.owin(i)) { ## detect 'blank' arguments like second argument in x[i, ] ngiven <- length(sys.call()) nmatched <- length(match.call()) nblank <- ngiven - nmatched itype <- if(missing(i)) "missing" else "given" jtype <- if(missing(j)) "missing" else "given" if(nblank == 1) { if(!missing(i)) jtype <- "blank" if(!missing(j)) itype <- "blank" } else if(nblank == 2) { itype <- jtype <- "blank" } if(missing(rescue) && itype != "given") rescue <- FALSE if(itype == "missing" && jtype == "missing") { ## no indices: return entire image out <- if(is.null(raster)) x else as.im(raster) xy <- expand.grid(y=out$yrow,x=out$xcol) if(!is.null(raster)) { ## resample image on new pixel raster values <- lookup.im(x, xy$x, xy$y, naok=TRUE) out <- im(values, out$xcol, out$yrow, unitname=unitname(out)) } if(!drop) return(out) else { v <- out$v return(v[!is.na(v)]) } } if(itype == "given") { ## ................................................................. ## Try spatial index ## ................................................................. if(verifyclass(i, "owin", fatal=FALSE)) { if(jtype == "given") warning("Argument j ignored") ## 'i' is a window ## if drop = FALSE, just set values outside window to NA ## if drop = TRUE, extract values for all pixels inside window ## as an image (if 'i' is a rectangle) ## or as a vector (otherwise) disjoint.frames <- disjoint(i$xrange, x$xrange) || disjoint(i$yrange, x$yrange) if(disjoint.frames && drop) return(numeric(0)) ## determine pixel raster for output if(!is.null(raster)) { out <- as.im(raster) do.resample <- TRUE } else if(is.subset.owin(i, as.owin(x))) { out <- x do.resample <- FALSE } else { ## new window does not contain data window: expand it bb <- boundingbox(as.rectangle(i), as.rectangle(x)) rr <- if(is.mask(i)) i else x xcol <- prolongseq(rr$xcol, bb$xrange, rr$xstep) yrow <- prolongseq(rr$yrow, bb$yrange, rr$ystep) out <- list(xcol=xcol, yrow=yrow) do.resample <- TRUE } xy <- expand.grid(y=out$yrow,x=out$xcol) if(do.resample) { ## resample image on new pixel raster values <- lookup.im(x, xy$x, xy$y, naok=TRUE) out <- im(values, out$xcol, out$yrow, unitname=unitname(out)) } inside <- inside.owin(xy$x, xy$y, i) if(drop && !(rescue && i$type == "rectangle")) { ## return pixel values (possibly including NA) values <- out$v[inside] return(values) } ## An image will be returned. ## pixels outside window 'i' have undefined values out$v[!inside] <- NA ## if(!drop && !tight) return(out) ## Return image in smaller rectangle (possibly an empty image) xr <- clip(i$xrange, x$xrange) yr <- clip(i$yrange, x$yrange) colsub <- inrange(out$xcol, xr) rowsub <- inrange(out$yrow, yr) ncolsub <- sum(colsub) nrowsub <- sum(rowsub) if(ncolsub > 1) { xcolsub <- out$xcol[colsub] } else { xcolsub <- mean(xr) if(diff(xr) == 0) xr <- c(-1,1) * out$xstep/2 } if(nrowsub > 1) { yrowsub <- out$yrow[rowsub] } else { yrowsub <- mean(yr) if(diff(yr) == 0) yr <- c(-1,1) * out$ystep/2 } if(ncolsub == 0 || nrowsub == 0) { ## intersection of grids is empty mat <- matrix(RelevantNA(x$v), max(nrowsub, 1L), max(ncolsub, 1L)) } else { mat <- out$v[rowsub, colsub, drop=FALSE] } result <- im(mat, xcol=xcolsub, xrange=xr, yrow=yrowsub, yrange=yr, unitname = unitname(x)) return(result) } if(verifyclass(i, "im", fatal=FALSE)) { if(jtype == "given") warning("Argument j ignored") ## logical images OK if(i$type == "logical") { ## convert to window w <- as.owin(eval.im(ifelse1NA(i))) return(x[w, drop=drop, ..., raster=raster]) } else stop("Subset argument \'i\' is an image, but not of logical type") } if(inherits(i, "linnet")) { #' linear network if(!requireNamespace("spatstat.linnet")) { warning(paste("X[L] where L is a linear network", "requires the package 'spatstat.linnet'"), call.=FALSE) return(NULL) } if(jtype == "given") warning("Argument j ignored") W <- raster %orifnull% as.owin(x) M <- psp2mask(as.psp(i), W=W, ...) xM <- x[M, drop=drop] if(is.im(xM)) xM <- spatstat.linnet::linim(i, xM) return(xM) } if(is.ppp(i)) { ## 'i' is a point pattern if(jtype == "given") warning("Argument j ignored") ## Look up the greyscale values for the points of the pattern values <- lookup.im(x, i$x, i$y, naok=TRUE) if(drop) values <- values[!is.na(values)] if(length(values) == 0) ## ensure the zero-length vector is of the right type values <- switch(x$type, factor={ factor(, levels=levels(x)) }, integer = { integer(0) }, logical = { logical(0) }, real = { numeric(0) }, complex = { complex(0) }, character = { character(0) }, { values } ) return(values) } } ## ............... not a spatial index ............................. ## Try indexing as a matrix ## Construct a matrix index call for possible re-use M <- as.matrix(x) ## suppress warnings from code checkers dont.complain.about(M) ## ycall <- switch(itype, given = { switch(jtype, given = quote(M[i, j, drop=FALSE]), blank = quote(M[i, , drop=FALSE]), missing = quote(M[i, drop=FALSE])) }, blank = { switch(jtype, given = quote(M[ , j, drop=FALSE]), blank = quote(M[ , , drop=FALSE]), missing = quote(M[ , drop=FALSE])) }, missing = { switch(jtype, given = quote(M[j=j, drop=FALSE]), blank = quote(M[j= , drop=FALSE]), missing = quote(M[ drop=FALSE])) }) ## try it y <- try(eval(as.call(ycall)), silent=TRUE) if(!inherits(y, "try-error")) { ## valid subset index for a matrix if(rescue) { ## check whether it's a rectangular block, in correct order RR <- row(x$v) CC <- col(x$v) rcall <- ycall rcall[[2L]] <- quote(RR) ccall <- ycall ccall[[2L]] <- quote(CC) rr <- eval(as.call(rcall)) cc <- eval(as.call(ccall)) rseq <- sortunique(as.vector(rr)) cseq <- sortunique(as.vector(cc)) if(all(diff(rseq) == 1) && all(diff(cseq) == 1) && (length(rr) == length(rseq) * length(cseq)) && all(rr == RR[rseq, cseq]) && all(cc == CC[rseq,cseq])) { ## yes - make image dim(y) <- c(length(rseq), length(cseq)) Y <- x Y$v <- y Y$dim <- dim(y) Y$xcol <- x$xcol[cseq] Y$yrow <- x$yrow[rseq] Y$xrange <- range(Y$xcol) + c(-1,1) * x$xstep/2 Y$yrange <- range(Y$yrow) + c(-1,1) * x$ystep/2 return(Y) } } ## return pixel values (possibly as matrix) return(y) } ## Last chance! if(itype == "given" && !is.matrix(i) && !is.null(ip <- as.ppp(i, W=as.owin(x), fatal=FALSE, check=FALSE))) { ## 'i' is convertible to a point pattern ## Look up the greyscale values for the points of the pattern values <- lookup.im(x, ip$x, ip$y, naok=TRUE) if(drop) values <- values[!is.na(values)] if(length(values) == 0) ## ensure the zero-length vector is of the right type values <- switch(x$type, factor={ factor(, levels=levels(x)) }, integer = { integer(0) }, logical = { logical(0) }, real = { numeric(0) }, complex = { complex(0) }, character = { character(0) }, { values } ) return(values) } stop("The subset operation is undefined for this type of index") } Extract.im }) update.im <- function(object, ...) { ## update internal structure of image after manipulation X <- object mat <- X$v typ <- typeof(mat) if(typ == "double") typ <- "real" ## deal with factor case if(is.factor(mat)) { typ <- "factor" } else if(!is.null(lev <- levels(mat))) { typ <- "factor" X$v <- factor(mat, levels=lev) } X$type <- typ return(X) } "[<-.im" <- function(x, i, j, ..., drop=TRUE, value) { # detect 'blank' arguments like second argument of x[i, ] ngiven <- length(sys.call()) nmatched <- length(match.call()) nblank <- ngiven - nmatched itype <- if(missing(i)) "missing" else "given" jtype <- if(missing(j)) "missing" else "given" if(nblank == 1) { if(!missing(i)) jtype <- "blank" if(!missing(j)) itype <- "blank" } else if(nblank == 2) { itype <- jtype <- "blank" } X <- x W <- as.owin(X) stopifnot(is.im(value) || is.vector(value) || is.matrix(value) || is.array(value) || is.factor(value)) if(is.im(value)) value <- value$v if(itype == "missing" && jtype == "missing") { #' no index provided #' set all pixels to 'value' #' (if drop=TRUE, this applies only to pixels inside the window) v <- X$v if(!is.factor(value)) { if(!drop) { v[] <- value } else { v[!is.na(v)] <- value } } else { vnew <- matrix(NA_integer_, ncol(v), nrow(v)) if(!drop) { vnew[] <- as.integer(value) } else { vnew[!is.na(v)] <- as.integer(value) } lnew <- levels(value) v <- factor(vnew, levels=seq_along(lnew), labels=lnew) } X$v <- v return(update(X)) } if(itype == "given") { # ..................... Try a spatial index .................... if(verifyclass(i, "owin", fatal=FALSE)) { if(jtype == "given") warning("Index j ignored") # 'i' is a window if(is.empty(i)) return(X) rxy <- rasterxy.mask(W) xx <- rxy$x yy <- rxy$y ok <- inside.owin(xx, yy, i) X$v[ok] <- value X$type <- ifelse(is.factor(X$v), "factor", typeof(X$v)) return(update(X)) } if(verifyclass(i, "im", fatal=FALSE) && i$type == "logical") { if(jtype == "given") warning("Index j ignored") # convert logical vector to window where entries are TRUE i <- as.owin(eval.im(ifelse1NA(i))) # continue as above rxy <- rasterxy.mask(W) xx <- rxy$x yy <- rxy$y ok <- inside.owin(xx, yy, i) X$v[ok] <- value X$type <- ifelse(is.factor(X$v), "factor", typeof(X$v)) return(update(X)) } if(is.ppp(i)) { # 'i' is a point pattern if(jtype == "given") warning("Index j ignored") nv <- length(value) np <- npoints(i) if(nv != np && nv != 1) stop("Length of replacement value != number of point locations") # test whether all points are inside window FRAME ok <- inside.owin(i$x, i$y, as.rectangle(W)) if(any(!ok)) { warning("Some points are outside the outer frame of the image") if(nv == np) value <- value[ok] i <- i[ok] } if(npoints(i) > 0) { # determine row & column positions for each point loc <- nearest.pixel(i$x, i$y, X) # set values X$v[cbind(loc$row, loc$col)] <- value } X$type <- ifelse(is.factor(X$v), "factor", typeof(X$v)) return(update(X)) } } # .................. 'i' is not a spatial index .................... # Construct a matrix replacement call ycall <- switch(itype, given = { switch(jtype, given = quote(X$v[i, j] <- value), blank = quote(X$v[i, ] <- value), missing = quote(X$v[i] <- value)) }, blank = { switch(jtype, given = quote(X$v[ , j] <- value), blank = quote(X$v[ , ] <- value), missing = quote(X$v[ ] <- value)) }, missing = { switch(jtype, given = quote(X$v[j=j] <- value), blank = quote(X$v[j= ] <- value), missing = quote(X$v[] <- value)) }) # try it litmus <- try(eval(as.call(ycall)), silent=TRUE) if(!inherits(litmus, "try-error")){ X$type <- ifelse(is.factor(X$v), "factor", typeof(X$v)) return(update(X)) } # Last chance! if(itype == "given" && !is.matrix(i) && !is.null(ip <- as.ppp(i, W=W, fatal=FALSE, check=TRUE))) { # 'i' is convertible to a point pattern if(jtype == "given") warning("Index j ignored") nv <- length(value) np <- npoints(ip) if(nv != np && nv != 1) stop("Length of replacement value != number of point locations") # test whether all points are inside window FRAME ok <- inside.owin(ip$x, ip$y, as.rectangle(W)) if(any(!ok)) { warning("Some points are outside the outer frame of the image") if(nv == np) value <- value[ok] ip <- ip[ok] } if(npoints(ip) > 0) { # determine row & column positions for each point loc <- nearest.pixel(ip$x, ip$y, X) # set values X$v[cbind(loc$row, loc$col)] <- value } X$type <- ifelse(is.factor(X$v), "factor", typeof(X$v)) return(update(X)) } stop("The subset operation is undefined for this type of index") } ################################################################ ######## other tools ################################################################ # # This function is similar to nearest.raster.point except for # the third argument 'im' and the different idiom for calculating # row & column - which could be used in nearest.raster.point() nearest.pixel <- function(x,y, Z) { stopifnot(is.im(Z) || is.mask(Z)) if(length(x) > 0) { nr <- Z$dim[1L] nc <- Z$dim[2L] cc <- as.integer(round(1 + (x - Z$xcol[1L])/Z$xstep)) rr <- as.integer(round(1 + (y - Z$yrow[1L])/Z$ystep)) cc <- pmax.int(1L,pmin.int(cc, nc)) rr <- pmax.int(1L,pmin.int(rr, nr)) } else cc <- rr <- integer(0) return(list(row=rr, col=cc)) } # Explores the 3 x 3 neighbourhood of nearest.pixel # and finds the nearest pixel that is not NA nearest.valid.pixel <- function(x, y, Z, method=c("C","interpreted"), nsearch=1) { method <- match.arg(method) switch(method, interpreted = { rc <- nearest.pixel(x,y,Z) # checks that Z is an 'im' or 'mask' rr <- rc$row cc <- rc$col #' check whether any pixels are outside image domain inside <- as.owin(Z)$m miss <- !inside[cbind(rr, cc)] if(!any(miss)) return(rc) #' for offending pixels, explore 3 x 3 neighbourhood (if nsearch=1) nr <- Z$dim[1L] nc <- Z$dim[2L] xcol <- Z$xcol yrow <- Z$yrow searching <- (-nsearch):(nsearch) for(i in which(miss)) { rows <- rr[i] + searching cols <- cc[i] + searching rows <- unique(pmax.int(1L, pmin.int(rows, nr))) cols <- unique(pmax.int(1L, pmin.int(cols, nc))) rcp <- expand.grid(row=rows, col=cols) ok <- inside[as.matrix(rcp)] if(any(ok)) { #' At least one of the neighbours is valid #' Find the closest one rcp <- rcp[ok,] dsq <- with(rcp, (x[i] - xcol[col])^2 + (y[i] - yrow[row])^2) j <- which.min(dsq) rc$row[i] <- rcp$row[j] rc$col[i] <- rcp$col[j] } } }, C = { stopifnot(is.im(Z) || is.mask(Z)) n <- length(x) if(n == 0) { cc <- rr <- integer(0) } else { nr <- Z$dim[1L] nc <- Z$dim[2L] xscaled <- (x - Z$xcol[1])/Z$xstep yscaled <- (y - Z$yrow[1])/Z$ystep aspect <- Z$ystep/Z$xstep inside <- as.owin(Z)$m zz <- .C(SG_nearestvalidpixel, n = as.integer(n), x = as.double(xscaled), y = as.double(yscaled), nr = as.integer(nr), nc = as.integer(nc), aspect = as.double(aspect), z = as.integer(inside), nsearch = as.integer(nsearch), rr = as.integer(integer(n)), cc = as.integer(integer(n)), PACKAGE="spatstat.geom") rr <- zz$rr + 1L cc <- zz$cc + 1L if(any(bad <- (rr == 0 | cc == 0))) { rr[bad] <- NA cc[bad] <- NA } } rc <- list(row=rr, col=cc) }) return(rc) } ## ................ IMAGE LOOKUP ................................ ## lookup.im() is a generalisation of inside.owin() ## to images other than binary-valued images. lookup.im <- function(Z, x, y, naok=FALSE, strict=TRUE) { verifyclass(Z, "im") if(Z$type == "factor") Z <- repair.old.factor.image(Z) if((missing(y) || is.null(y)) && all(c("x", "y") %in% names(x))) { y <- x$y x <- x$x } if(length(x) != length(y)) stop("x and y must be numeric vectors of equal length") # initialise answer to NA if(Z$type != "factor") { niets <- NA mode(niets) <- mode(Z$v) } else { niets <- factor(NA, levels=levels(Z)) } value <- rep.int(niets, length(x)) # test whether inside bounding rectangle xr <- Z$xrange yr <- Z$yrange eps <- sqrt(.Machine$double.eps) frameok <- (x >= xr[1L] - eps) & (x <= xr[2L] + eps) & (y >= yr[1L] - eps) & (y <= yr[2L] + eps) if(!any(frameok)) { # all points OUTSIDE range - no further work needed if(!naok) warning("Internal error: all values NA") return(value) # all NA } # consider only those points which are inside the frame xf <- x[frameok] yf <- y[frameok] # map locations to raster (row,col) coordinates if(strict) loc <- nearest.pixel(xf,yf,Z) else loc <- nearest.valid.pixel(xf,yf,Z) # look up image values vf <- Z$v[cbind(loc$row, loc$col)] # insert into answer value[frameok] <- vf if(!naok && anyNA(value)) warning("Internal error: NA's generated") return(value) } ## safelookup() ensures that a finite value is obtained for each query location safelookup <- function(Z, x, factor=2, warn=TRUE) { #' x is a ppp giving the query points. #' Evaluates Z[x], replacing any NA's by values at nearby pixels #' First pass - look up pixel values at query locations Zvals <- Z[x, drop=FALSE] isna <- is.na(Zvals) if(!any(isna)) return(Zvals) #' Second pass - look up values at neighbouring pixels if valid Xbad <- x[isna] rc <- nearest.valid.pixel(Xbad$x, Xbad$y, Z, nsearch=ceiling(factor)) Nvals <- Z$v[cbind(rc$row, rc$col)] fixed <- !is.na(Nvals) Zvals[isna] <- Nvals if(all(fixed)) return(Zvals) notfixed <- !fixed isna[isna] <- notfixed Xbad <- Xbad[notfixed] #' Third pass - project to nearest pixel at any distance W <- as.mask(Z) eW <- exactPdt(W) ## discretise points of Xbad Gbad <- nearest.raster.point(Xbad$x, Xbad$y, W) ijGbad <- cbind(Gbad$row, Gbad$col) ## find nearest pixels inside domain iclosest <- eW$row[ijGbad] jclosest <- eW$col[ijGbad] ## look up values of Z Cvals <- Z$v[cbind(iclosest, jclosest)] fixed <- !is.na(Cvals) Zvals[isna] <- Cvals nfixed <- sum(fixed) if(warn && nfixed > 0) warning(paste("Values for", nfixed, "query", ngettext(nfixed, "point", "points"), "lying outside the pixel image domain", "were estimated by projection to the nearest pixel"), call.=FALSE) if(!all(fixed)) stop(paste("Internal error:", sum(!fixed), "pixel values were NA, even after projection"), call.=FALSE) return(Zvals) } nearestValue <- function(X) { #' For EACH raster location, look up the nearest defined pixel value #' regardless of how far away it is. Return an image. X <- as.im(X) if(!anyNA(X)) return(X) Y <- X ## copy dimensions, value type, units etc etc W <- as.mask(X) eW <- exactPdt(W) iclosest <- as.vector(eW$row) jclosest <- as.vector(eW$col) ## look up values of Z Y$v[] <- X$v[cbind(iclosest, jclosest)] return(Y) } ## .............. low level ................................... rasterx.im <- function(x) { verifyclass(x, "im") xx <- x$xcol matrix(xx[col(x)], ncol=ncol(x), nrow=nrow(x)) } rastery.im <- function(x) { verifyclass(x, "im") yy <- x$yrow matrix(yy[row(x)], ncol=ncol(x), nrow=nrow(x)) } rasterxy.im <- function(x, drop=FALSE) { verifyclass(x, "im") xx <- x$xcol yy <- x$yrow ans <- cbind(x=as.vector(xx[col(x)]), y=as.vector(yy[row(x)])) if(drop) { ok <- as.vector(!is.na(x$v)) ans <- ans[ok, , drop=FALSE] } return(ans) } ## user interface raster.x <- function(w, drop=FALSE) { if(is.owin(w)) return(rasterx.mask(w, drop=drop)) if(!is.im(w)) stop("w should be a window or an image") x <- w$xcol[col(w)] x <- if(drop) x[!is.na(w$v), drop=TRUE] else array(x, dim=w$dim) return(x) } raster.y <- function(w, drop=FALSE) { if(is.owin(w)) return(rastery.mask(w, drop=drop)) if(!is.im(w)) stop("w should be a window or an image") y <- w$yrow[row(w)] y <- if(drop) y[!is.na(w$v), drop=TRUE] else array(y, dim=w$dim) return(y) } raster.xy <- function(w, drop=FALSE) { if(is.owin(w)) return(rasterxy.mask(w, drop=drop)) if(!is.im(w)) stop("w should be a window or an image") x <- w$xcol[col(w)] y <- w$yrow[row(w)] if(drop) { ok <- !is.na(w$v) x <- x[ok, drop=TRUE] y <- y[ok, drop=TRUE] } return(list(x=as.numeric(x), y=as.numeric(y))) } ############## # methods for other functions xtfrm.im <- function(x) { as.numeric(as.matrix.im(x)) } as.matrix.im <- function(x, ...) { return(x$v) } as.array.im <- function(x, ...) { m <- as.matrix(x) a <- do.call(array, resolve.defaults(list(quote(m)), list(...), list(dim=c(dim(m), 1)))) return(a) } as.data.frame.im <- function(x, ...) { verifyclass(x, "im") v <- x$v xx <- x$xcol[col(v)] yy <- x$yrow[row(v)] ok <- !is.na(v) xx <- as.vector(xx[ok]) yy <- as.vector(yy[ok]) # extract pixel values without losing factor info vv <- v[ok] dim(vv) <- NULL # data.frame(x=xx, y=yy, value=vv, ...) } mean.im <- function(x, trim=0, na.rm=TRUE, ...) { verifyclass(x, "im") xvalues <- x[drop=na.rm] return(mean(xvalues, trim=trim, na.rm=na.rm)) } ## arguments of generic 'median' will change in R 3.4 median.im <- if("..." %in% names(formals(median))) { function(x, na.rm=TRUE, ...) { verifyclass(x, "im") xvalues <- x[drop=na.rm] return(median(xvalues, ...)) } } else { function(x, na.rm=TRUE) { verifyclass(x, "im") xvalues <- x[drop=na.rm] return(median(xvalues)) } } where.max <- function(x, first=TRUE) { x <- as.im(x) if(first) { ## find the first maximum v <- x$v locn <- which.max(as.vector(v)) # ignores NA, NaN locrow <- as.vector(row(v))[locn] loccol <- as.vector(col(v))[locn] } else { ## find all maxima xmax <- max(x) M <- solutionset(x == xmax) loc <- which(M$m, arr.ind=TRUE) locrow <- loc[,1L] loccol <- loc[,2L] } xx <- x$xcol[loccol] yy <- x$yrow[locrow] return(ppp(x=xx, y=yy, window=Window(x))) } where.min <- function(x, first=TRUE) { x <- as.im(x) if(first) { ## find the first minimum v <- x$v locn <- which.min(as.vector(v)) # ignores NA, NaN locrow <- as.vector(row(v))[locn] loccol <- as.vector(col(v))[locn] } else { ## find all minima xmin <- min(x) M <- solutionset(x == xmin) loc <- which(M$m, arr.ind=TRUE) locrow <- loc[,1L] loccol <- loc[,2L] } xx <- x$xcol[loccol] yy <- x$yrow[locrow] return(ppp(x=xx, y=yy, window=Window(x))) } ## the following ensures that 'sd' works as.double.im <- function(x, ...) { as.double(x[], ...) } ## hist.im <- function(x, ..., probability=FALSE, xname) { if(missing(xname) || is.null(xname)) xname <- short.deparse(substitute(x)) verifyclass(x, "im") main <- paste("Histogram of", xname) # default plot arguments # extract pixel values values <- as.matrix(x) dim(values) <- NULL # barplot or histogram if(x$type %in% c("logical", "factor")) { # barplot tab <- table(values) probs <- tab/sum(tab) if(probability) { heights <- probs ylab <- "Probability" } else { heights <- tab ylab <- "Number of pixels" } mids <- do.call(barplot, resolve.defaults(list(heights), list(...), list(xlab=paste("Pixel value"), ylab=ylab, main=main))) out <- list(counts=tab, probs=probs, heights=heights, mids=mids, xname=xname) class(out) <- "barplotdata" } else { # histogram values <- values[!is.na(values)] plotit <- resolve.defaults(list(...), list(plot=TRUE))$plot if(plotit) { ylab <- if(probability) "Probability density" else "Number of pixels" out <- do.call(hist.default, resolve.defaults(list(quote(values)), list(...), list(freq=!probability, xlab="Pixel value", ylab=ylab, main=main))) out$xname <- xname } else { # plot.default whinges if `probability' given when plot=FALSE out <- do.call(hist.default, resolve.defaults(list(quote(values)), list(...))) # hack! out$xname <- xname } } return(invisible(out)) } plot.barplotdata <- function(x, ...) { do.call(barplot, resolve.defaults(list(height=x$heights), list(...), list(main=paste("Histogram of ", x$xname)))) } cut.im <- function(x, ...) { verifyclass(x, "im") typ <- x$type if(typ %in% c("factor", "logical", "character")) stop(paste0("cut.im is not defined for ", typ, "-valued images"), call.=FALSE) vcut <- cut(as.numeric(as.matrix(x)), ...) return(im(vcut, xcol=x$xcol, yrow=x$yrow, xrange=x$xrange, yrange=x$yrange, unitname=unitname(x))) } quantile.im <- function(x, ...) { verifyclass(x, "im") x <- as.numeric(as.matrix(x)) q <- do.call(quantile, resolve.defaults(list(quote(x)), list(...), list(na.rm=TRUE))) return(q) } quantilefun.im <- function(x, ..., type=1) { verifyclass(x, "im") f <- ecdf(as.numeric(x[])) quantilefun(f, type=type) } integral.im <- function(f, domain=NULL, weight=NULL, ...) { verifyclass(f, "im") if(!is.null(weight)) { if(is.function(weight)) weight <- as.im(weight, W=as.owin(f)) f <- f * weight } typ <- f$type if(!any(typ == c("integer", "real", "complex", "logical"))) stop(paste("Don't know how to integrate an image of type", sQuote(typ))) if(is.tess(domain)) { doh <- as.im(domain, W=as.mask(f)) fx <- as.vector(as.matrix(f)) dx <- factor(as.integer(as.matrix(doh))) a <- tapplysum(fx, list(dx)) * with(f, xstep * ystep) names(a) <- tilenames(domain) return(a) } if(!is.null(domain)) f <- f[domain, drop=FALSE, tight=TRUE] a <- with(f, sum(v, na.rm=TRUE) * xstep * ystep) return(a) } conform.imagelist <- function(X, Zlist) { # determine points of X where all images in Zlist are defined ok <- rep.int(TRUE, length(X$x)) for(i in seq_along(Zlist)) { Zi <- Zlist[[i]] ZiX <- Zi[X, drop=FALSE] ok <- ok & !is.na(ZiX) } return(ok) } split.im <- function(x, f, ..., drop=FALSE) { stopifnot(is.im(x)) if(inherits(f, "tess")) subsets <- tiles(f) else if(is.im(f)) { if(f$type != "factor") f <- eval.im(factor(f)) subsets <- tiles(tess(image=f)) } else stop("f should be a tessellation or a factor-valued image") if(!is.subset.owin(as.owin(x), as.owin(f))) stop("f does not cover the window of x") n <- length(subsets) out <- vector(mode="list", length=n) names(out) <- names(subsets) for(i in 1:n) out[[i]] <- x[subsets[[i]], drop=drop] if(drop) return(out) else return(as.solist(out)) } by.im <- function(data, INDICES, FUN, ...) { stopifnot(is.im(data)) V <- split(data, INDICES) U <- lapply(V, FUN, ...) return(as.solist(U, demote=TRUE)) } rebound.im <- function(x, rect) { stopifnot(is.im(x)) stopifnot(is.owin(rect)) rect <- as.rectangle(rect) stopifnot(is.subset.owin(as.rectangle(x), rect)) # compute number of extra rows/columns dx <- x$xstep nleft <- max(0, floor((x$xrange[1L]-rect$xrange[1L])/dx)) nright <- max(0, floor((rect$xrange[2L]-x$xrange[2L])/dx)) dy <- x$ystep nbot <- max(0, floor((x$yrange[1L]-rect$yrange[1L])/dy)) ntop <- max(0, floor((rect$yrange[2L]-x$yrange[2L])/dy)) # determine exact x and y ranges (to preserve original pixel locations) xrange.new <- x$xrange + c(-nleft, nright) * dx yrange.new <- x$yrange + c(-nbot, ntop) * dy # expand pixel data matrix nr <- x$dim[1L] nc <- x$dim[2L] nrnew <- nbot + nr + ntop ncnew <- nleft + nc + nright naval <- switch(x$type, factor=, integer=NA_integer_, real=NA_real_, character=NA_character_, complex=NA_complex_, NA) vnew <- matrix(naval, nrnew, ncnew) if(x$type != "factor") { vnew[nbot + (1:nr), nleft + (1:nc)] <- x$v } else { vnew[nbot + (1:nr), nleft + (1:nc)] <- as.integer(x$v) vnew <- factor(vnew, labels=levels(x)) dim(vnew) <- c(nrnew, ncnew) } # build new image object xnew <- im(vnew, xrange = xrange.new, yrange = yrange.new, unitname = unitname(x)) return(xnew) } sort.im <- function(x, ...) { verifyclass(x, "im") sort(as.vector(as.matrix(x)), ...) } dim.im <- function(x) { x$dim } # colour images rgbim <- function(R, G, B, A=NULL, maxColorValue=255, autoscale=FALSE) { if(autoscale) { R <- scaletointerval(R, 0, maxColorValue) G <- scaletointerval(G, 0, maxColorValue) B <- scaletointerval(B, 0, maxColorValue) if(!is.null(A)) A <- scaletointerval(A, 0, maxColorValue) } Z <- eval.im(factor(rgbNA(as.vector(R), as.vector(G), as.vector(B), as.vector(A), maxColorValue=maxColorValue))) return(Z) } hsvim <- function(H, S, V, A=NULL, autoscale=FALSE) { if(autoscale) { H <- scaletointerval(H, 0, 1) S <- scaletointerval(S, 0, 1) V <- scaletointerval(V, 0, 1) if(!is.null(A)) A <- scaletointerval(A, 0, 1) } Z <- eval.im(factor(hsvNA(as.vector(H), as.vector(S), as.vector(V), as.vector(A)))) return(Z) } scaletointerval <- function(x, from=0, to=1, xrange=range(x)) { UseMethod("scaletointerval") } scaletointerval.default <- function(x, from=0, to=1, xrange=range(x)) { x <- as.numeric(x) rr <- if(missing(xrange)) range(x, na.rm=TRUE) else as.numeric(xrange) b <- as.numeric(to - from)/diff(rr) if(is.finite(b)) { y <- from + b * (x - rr[1L]) } else { y <- (from+to)/2 + 0 * x } y[] <- pmin(pmax(y[], from), to) return(y) } scaletointerval.im <- function(x, from=0, to=1, xrange=range(x)) { v <- scaletointerval(x$v, from, to, xrange=xrange) y <- im(v, x$xcol, x$yrow, x$xrange, x$yrange, unitname(x)) return(y) } zapsmall.im <- function(x, digits) { if(missing(digits)) return(eval.im(zapsmall(x))) return(eval.im(zapsmall(x, digits=digits))) } domain.im <- Window.im <- function(X, ...) { as.owin(X) } "Window<-.im" <- function(X, ..., value) { verifyclass(value, "owin") X[value, drop=FALSE] } padimage <- function(X, value=NA, n=1, W=NULL) { stopifnot(is.im(X)) stopifnot(length(value) == 1) if(!missing(n) && !is.null(W)) stop("Arguments n and W are incompatible", call.=FALSE) padW <- !is.null(W) if(isfac <- (X$type == "factor")) { ## handle factors levX <- levels(X) if(is.factor(value)) { stopifnot(identical(levels(X), levels(value))) } else { value <- factor(value, levels=levX) } X <- eval.im(as.integer(X)) value <- as.integer(value) } if(!padW) { ## pad by 'n' pixels nn <- rep(n, 4) nleft <- nn[1L] nright <- nn[2L] nbottom <- nn[3L] ntop <- nn[4L] } else { ## pad out to window W FX <- Frame(X) B <- boundingbox(Frame(W), FX) nleft <- max(1, round((FX$xrange[1L] - B$xrange[1L])/X$xstep)) nright <- max(1, round((B$xrange[2L] - FX$xrange[2L])/X$xstep)) nbottom <- max(1, round((FX$yrange[1L] - B$yrange[1L])/X$ystep)) ntop <- max(1, round((B$yrange[2L] - FX$yrange[2L])/X$ystep)) } mX <- as.matrix(X) dd <- dim(mX) mX <- cbind(matrix(value, dd[1L], nleft, byrow=TRUE), as.matrix(X), matrix(value, dd[1L], nright, byrow=TRUE)) dd <- dim(mX) mX <- rbind(matrix(rev(value), nbottom, dd[2L]), mX, matrix(value, ntop, dd[2L])) xcol <- with(X, c(xcol[1L] - (nleft:1) * xstep, xcol, xcol[length(xcol)] + (1:nright) * xstep)) yrow <- with(X, c(yrow[1L] - (nbottom:1) * ystep, yrow, yrow[length(yrow)] + (1:ntop) * ystep)) xr <- with(X, xrange + c(-nleft, nright) * xstep) yr <- with(X, yrange + c(-nbottom, ntop) * ystep) Y <- im(mX, xcol=xcol, yrow=yrow, xrange=xr, yrange=yr, unitname=unitname(X)) if(isfac) Y <- eval.im(factor(Y, levels=seq_along(levX), labels=levX)) if(padW && !is.rectangle(W)) Y <- Y[W, drop=FALSE] return(Y) } as.function.im <- function(x, ...) { Z <- x f <- function(x,y) { Z[list(x=x, y=y)] } g <- funxy(f, Window(x)) return(g) } anyNA.im <- function(x, recursive=FALSE) { anyNA(x$v) } ZeroValue <- function(x) { UseMethod("ZeroValue") } ZeroValue.im <- function(x) { lev <- levels(x) z <- switch(x$type, factor = factor(lev[1L], levels=lev), integer = integer(1L), logical = logical(1L), real = numeric(1L), complex = complex(1L), character = character(1L), x$v[!is.na(x$v),drop=TRUE][1]) return(z) } ## replace 'NA' pixel values with a specified value fillNA <- function(x, value=0) { stopifnot(is.im(x)) v <- x$v v[is.na(v)] <- value x$v <- v return(x) } spatstat.geom/R/quadscheme.R0000644000176200001440000002353714700461464015526 0ustar liggesusers# # # quadscheme.S # # $Revision: 4.36 $ $Date: 2024/10/06 10:13:13 $ # # quadscheme() generate a quadrature scheme from # data and dummy point patterns. # # quadscheme.spatial() case where both patterns are unmarked # # quadscheme.replicated() case where data are multitype # # #--------------------------------------------------------------------- quadscheme <- function(data, dummy, method="grid", ...) { # # generate a quadrature scheme from data and dummy patterns. # # Other arguments control how the quadrature weights are computed # data <- as.ppp(data) if(missing(dummy)) { # create dummy points dummy <- default.dummy(data, method=method, ...) # extract full set of parameters used to create dummy points dp <- attr(dummy, "dummy.parameters") # extract recommended parameters for computing weights wp <- attr(dummy, "weight.parameters") } else { # user-supplied dummy points if(!is.ppp(dummy)) { # convert to ppp object dummy <- as.ppp(dummy, data$window, check=FALSE) # confine dummy points to data window dummy <- dummy[data$window] wp <- dp <- list() } else { # if it's already a ppp, it may have been created by default.dummy dp <- attr(dummy, "dummy.parameters") wp <- attr(dummy, "weight.parameters") } } # arguments supplied directly to quadscheme() # override any arguments passed as attributes wp <- resolve.defaults(list(method=method), list(...), wp) mX <- is.marked(data) mD <- is.marked(dummy) if(!mX && !mD) Q <- do.call(quadscheme.spatial, append(list(data, dummy, check=FALSE), wp)) else if(mX && !mD) Q <- do.call(quadscheme.replicated, append(list(data, dummy, check=FALSE), wp)) else if(!mX && mD) stop("dummy points are marked but data are unmarked") else stop("marked data and marked dummy points -- sorry, this case is not implemented") # record parameters used to make dummy points Q$param$dummy <- dp return(Q) } quadscheme.spatial <- function(data, dummy, method=c("grid", "dirichlet"), ...) { # # generate a quadrature scheme from data and dummy patterns. # # The 'method' may be "grid" or "dirichlet" # # '...' are passed to gridweights() or dirichletWeights() # # quadscheme.spatial: # for unmarked point patterns. # # weights are determined only by spatial locations # (i.e. weight computations ignore any marks) # # No two points should have the same spatial location # check <- resolve.defaults(list(...), list(check=TRUE))$check method <- match.arg(method) data <- as.ppp(data, check=check) dummy <- as.ppp(dummy, data$window, check=check) # note data$window is the DEFAULT quadrature window # applicable when 'dummy' does not contain a window if(is.marked(data, dfok=TRUE)) warning("marks in data pattern - ignored") if(is.marked(dummy, dfok=TRUE)) warning("marks in dummy pattern - ignored") both <- as.ppp(concatxy(data, dummy), dummy$window, check=check) switch(method, grid={ w <- gridweights(both, window= dummy$window, ...) }, dirichlet = { w <- dirichletWeights(both, window=dummy$window, ...) }, { stop(paste("unrecognised method", sQuote(method))) } ) # parameters actually used to make weights wp <- attr(w, "weight.parameters") param <- list(weight = wp, dummy = NULL) Q <- quad(data, dummy, w, param) return(Q) } "quadscheme.replicated" <- function(data, dummy, method=c("grid", "dirichlet"), ...) { ## ## generate a quadrature scheme from data and dummy patterns. ## ## The 'method' may be "grid" or "dirichlet" ## ## '...' are passed to gridweights() or dirichletWeights() ## ## quadscheme.replicated: ## for multitype point patterns. ## ## No two points in 'data'+'dummy' should have the same spatial location check <- resolve.defaults(list(...), list(check=TRUE))$check method <- match.arg(method) data <- as.ppp(data, check=check) dummy <- as.ppp(dummy, data$window, check=check) ## note data$window is the DEFAULT quadrature window ## unless otherwise specified in 'dummy' ndata <- data$n ndummy <- dummy$n if(!is.marked(data)) stop("data pattern does not have marks") if(is.marked(dummy, dfok=TRUE) && npoints(dummy) > 0) warning("dummy points have marks --- ignored") ## first, ignore marks and compute spatial weights P <- quadscheme.spatial(unmark(data), dummy, method, ...) W <- w.quad(P) iz <- is.data(P) Wdat <- W[iz] Wdum <- W[!iz] ## find the set of all possible marks if(!is.multitype(data)) stop("data pattern is not multitype") data.marks <- marks(data) markset <- levels(data.marks) nmarks <- length(markset) ## replicate dummy points, one copy for each possible mark ## -> dummy x {1,..,K} dumdum <- cartesian(dummy, markset) Wdumdum <- rep.int(Wdum, nmarks) Idumdum <- rep.int(ndata + seq_len(ndummy), nmarks) ## also make dummy marked points at same locations as data points ## but with different marks dumdat <- cartesian(unmark(data), markset) Wdumdat <- rep.int(Wdat, nmarks) Mdumdat <- marks(dumdat) Idumdat <- rep.int(1:ndata, nmarks) Mrepdat <- rep.int(data.marks, nmarks) ok <- (Mdumdat != Mrepdat) dumdat <- dumdat[ok,] Wdumdat <- Wdumdat[ok] Idumdat <- Idumdat[ok] ## combine the two dummy patterns dumb <- superimpose(dumdum, dumdat, W=dummy$window, check=FALSE) Wdumb <- c(Wdumdum, Wdumdat) Idumb <- c(Idumdum, Idumdat) ## record the quadrature parameters param <- list(weight = P$param$weight, dummy = NULL, sourceid=c(1:ndata, Idumb)) ## wrap up Q <- quad(data, dumb, c(Wdat, Wdumb), param) return(Q) } "cartesian" <- function(pp, markset, fac=TRUE) { ## given an unmarked point pattern 'pp' ## and a finite set of marks, ## create the marked point pattern which is ## the Cartesian product, consisting of all pairs (u,k) ## where u is a point of 'pp' and k is a mark in 'markset' nmarks <- length(markset) result <- ppp(rep.int(pp$x, nmarks), rep.int(pp$y, nmarks), window=pp$window, check=FALSE) marx <- rep.int(markset, rep.int(pp$n, nmarks)) if(fac) marx <- factor(marx, levels=markset) marks(result) <- marx return(result) } validate.quad <- function(Q, fatal=FALSE, repair=TRUE, announce=FALSE) { X <- Q$data D <- Q$dummy mX <- is.marked(X) mD <- is.marked(D) nbg <- function(whinge, fatal=FALSE, announce=FALSE) { if(fatal) stop(whinge, call.=FALSE) else { if(announce) warning(whinge, call.=FALSE) return(FALSE) } } if(mX != mD) { whinge <- if(mX) "data points are marked, but dummy points are not" else "dummy points are marked, but data points are not" return(nbg(whinge, fatal, announce)) } if(!mX) return(TRUE) # marked points fX <- is.factor(Xmarx <- marks(X)) fD <- is.factor(Dmarx <- marks(D)) if(fX != fD) { whinge <- if(fX) "data points are multitype, but dummy points are not" else "dummy points are multitype, but data points are not" return(nbg(whinge, fatal, announce)) } if(!fX) return(TRUE) # multitype points lX <- levels(Xmarx) lD <- levels(Dmarx) if(length(lX) != length(lD) || any(lX != lD)) { whinge <- "data and dummy points have different sets of possible marks" return(nbg(whinge, fatal, announce)) } return(TRUE) } pixelquad <- function(X, W=as.owin(X), ...) { ## make a quadscheme with a dummy point at every pixel verifyclass(X, "ppp") ## convert window to mask if not already one W <- as.owin(W) M <- AsMaskInternal(W, ...) MM <- M$m pixelarea <- M$xstep * M$ystep ## create pixel coordinates and corresponding row, column indices rxy <- rasterxy.mask(M, drop=TRUE) xx <- rxy$x yy <- rxy$y cc <- as.vector(col(MM)[MM]) rr <- as.vector(row(MM)[MM]) Nr <- M$dim[1] Nc <- M$dim[2] ## dummy point pattern dum <- ppp(xx, yy, window=W, check=FALSE) ## discretise data points ij <- nearest.raster.point(X$x, X$y, M) ijrow <- ij$row ijcol <- ij$col if(!is.marked(X)) { ## tabulate pixel locations of data points Xtab <- table(row=factor(ijrow, levels=1:Nr), col=factor(ijcol, levels=1:Nc)) ## every pixel contains exactly one dummy point, ## so the total count of quadrature points in each pixel is: Qtab <- Xtab + 1 ## compute counting weights for data points wdat <- 1/Qtab[cbind(ijrow, ijcol)] ## compute counting weights for dummy points wdum <- 1/Qtab[cbind(rr, cc)] } else { marx <- marks(X) ## tabulate pixel locations and marks of data points Xtab <- table(row=factor(ijrow, levels=1:Nr), col=factor(ijcol, levels=1:Nc), mark=marx) ## replicate dummy points (pixel centres) for each mark dum <- cartesian(dum, levels(marx)) ## every marked pixel contains exactly one dummy point, ## so the total count of quadrature points in each marked pixel is: Qtab <- Xtab + 1 ## compute counting weights for data points wdat <- 1/Qtab[cbind(ijrow, ijcol, as.integer(marx))] ## compute counting weights for dummy points nm <- length(levels(marx)) wdum <- 1/Qtab[cbind(rep.int(rr, nm), rep.int(cc, nm), rep(1:nm, each=length(rr)))] } ## create quadrature scheme wboth <- pixelarea * c(wdat, wdum) Q <- quad(X, dum, wboth) attr(Q, "M") <- M return(Q) } spatstat.geom/R/classes.R0000644000176200001440000000232314611065351015026 0ustar liggesusers# # # classes.S # # $Revision: 1.7 $ $Date: 2006/10/09 03:38:14 $ # # Generic utilities for classes # # #-------------------------------------------------------------------------- verifyclass <- function(X, C, N=deparse(substitute(X)), fatal=TRUE) { if(!inherits(X, C)) { if(fatal) { gripe <- paste("argument", sQuote(N), "is not of class", sQuote(C)) stop(gripe) } else return(FALSE) } return(TRUE) } #-------------------------------------------------------------------------- checkfields <- function(X, L) { # X is a list, L is a vector of strings # Checks for presence of field named L[i] for all i return(all(!is.na(match(L,names(X))))) } getfields <- function(X, L, fatal=TRUE) { # X is a list, L is a vector of strings # Extracts all fields with names L[i] from list X # Checks for presence of all desired fields # Returns the sublist of X with fields named L[i] absent <- is.na(match(L, names(X))) if(any(absent)) { gripe <- paste("Needed the following components:", paste(L, collapse=", "), "\nThese ones were missing: ", paste(L[absent], collapse=", ")) if(fatal) stop(gripe) else warning(gripe) } return(X[L[!absent]]) } spatstat.geom/R/quantess.R0000644000176200001440000002165014611065352015241 0ustar liggesusers#' quantess.R #' #' Quantile Tessellation #' #' $Revision: 1.24 $ $Date: 2023/06/02 02:42:09 $ quantess <- function(M, Z, n, ...) { UseMethod("quantess") } quantess.owin <- function(M, Z, n, ..., type=2, origin=c(0,0), eps=NULL) { W <- as.owin(M) B <- boundingbox(W) tcross <- MinimalTess(W, ...) force(n) if(!is.character(Z)) { Zim <- as.im(Z, W, eps=eps) Zrange <- range(Zim) } else { Z <- match.arg(Z, c("x", "y", "rad", "ang")) if(Z %in% c("x", "y") && is.rectangle(W)) { out <- switch(Z, x={ quadrats(W, nx=n, ny=1) }, y={ quadrats(W, nx=1, ny=n) }) if(!is.null(tcross)) out <- intersect.tess(out, tcross) return(out) } a <- qtPrepareCoordinate(Z, W, origin) Zfun <- a$Zfun Zrange <- a$Zrange Zim <- as.im(Zfun, W, eps=eps) } qZ <- quantile(Zim, probs=(0:n)/n, type=type) qZ[1] <- min(qZ[1], Zrange[1]) qZ[n+1] <- max(qZ[n+1], Zrange[2]) if(is.polygonal(W) && is.character(Z)) { R <- Frame(W) strips <- switch(Z, x = tess(xgrid=qZ, ygrid=R$yrange), y = tess(xgrid=R$xrange, ygrid=qZ), rad = polartess(B, radii=qZ, origin=origin), ang = polartess(B, angles=qZ, origin=origin)) out <- intersect.tess(strips, W) tilenames(out) <- makeCutLabels(qZ, include.lowest=TRUE) } else { ZC <- cut(Zim, breaks=qZ, include.lowest=TRUE) out <- tess(image=ZC) } if(!is.null(tcross)) out <- intersect.tess(out, tcross) return(out) } qtPrepareCoordinate <- function(covname, W, origin=c(0,0)) { switch(covname, x={ Zfun <- function(x,y){x} Zrange <- boundingbox(W)$xrange }, y={ Zfun <- function(x,y){y} Zrange <- boundingbox(W)$yrange }, rad={ origin <- interpretAsOrigin(origin, W) Zfun <- function(x,y) { sqrt((x-origin[1])^2+(y-origin[2])^2) } V <- vertices(W) Zrange <- range(Zfun(V$x, V$y)) }, ang={ origin <- interpretAsOrigin(origin, W) Zstart <- 0 Zfun <- function(x,y) { angle <- atan2(y-origin[2], x-origin[1]) %% (2*pi) if(Zstart < 0) { negangle <- angle - 2*pi angle <- ifelse(negangle >= Zstart, negangle, angle) } return(angle) } S <- as.data.frame(edges(W)) a <- Zfun(S[,"x0"], S[,"y0"]) b <- Zfun(S[,"x1"], S[,"y1"]) bmina <- b - a swap <- (bmina > pi) | (bmina < 0 & bmina > -pi) arcs <- cbind(ifelse(swap, b, a), ifelse(swap, a, b)) arcs <- lapply(apply(arcs, 1, list), unlist) Zunion <- circunion(arcs) Zrange <- c(Zunion[[1]][1], Zunion[[length(Zunion)]][2]) if(diff(Zrange) < 0) { #' first interval straddles the positive x-axis Zstart <- Zrange[1] <- Zrange[1] - 2*pi } }) return(list(Zrange=Zrange, Zfun=Zfun)) } quantess.ppp <- function(M, Z, n, ..., type=2, origin=c(0,0), eps=NULL) { W <- as.owin(M) B <- boundingbox(W) tcross <- MinimalTess(W, ...) force(n) if(!is.character(Z)) { Zim <- as.im(Z, W, eps=eps) ZM <- if(is.function(Z)) Z(M$x, M$y) else Zim[M] Zrange <- range(range(Zim), ZM) } else { Z <- match.arg(Z, c("x", "y", "rad", "ang")) if(Z %in% c("x", "y") && is.rectangle(W)) { switch(Z, x={ qx <- quantile(M$x, probs=(1:(n-1))/n, type=type) qx <- c(W$xrange[1], qx, W$xrange[2]) out <- tess(xgrid=qx, ygrid=W$yrange) }, y={ qy <- quantile(M$y, probs=(1:(n-1))/n, type=type) qy <- c(W$yrange[1], qy, W$yrange[2]) out <- tess(xgrid=W$xrange, ygrid=qy) }) if(!is.null(tcross)) out <- intersect.tess(out, tcross) return(out) } a <- qtPrepareCoordinate(Z, W, origin) Zrange <- a$Zrange Zfun <- a$Zfun ZM <- Zfun(M$x, M$y) Zrange <- range(Zrange, range(ZM)) Zim <- as.im(Zfun, W, eps=eps) } qZ <- quantile(Zim, probs=(0:n)/n, type=type) qZ[1] <- min(qZ[1], Zrange[1]) qZ[n+1] <- max(qZ[n+1], Zrange[2]) if(is.polygonal(W) && is.character(Z)) { R <- Frame(W) strips <- switch(Z, x = tess(xgrid=qZ, ygrid=R$yrange), y = tess(xgrid=R$xrange, ygrid=qZ), rad = polartess(B, radii=qZ, origin=origin), ang = polartess(B, angles=qZ, origin=origin)) out <- intersect.tess(strips, tess(tiles=list(W))) tilenames(out) <- makeCutLabels(qZ, include.lowest=TRUE) } else { ZC <- cut(Zim, breaks=qZ, include.lowest=TRUE) out <- tess(image=ZC) } if(!is.null(tcross)) out <- intersect.tess(out, tcross) return(out) } quantess.im <- function(M, Z, n, ..., type=2, origin=c(0,0)) { W <- Window(M) tcross <- MinimalTess(W, ...) force(n) if(!(type %in% c(1,2))) stop("Only quantiles of type 1 and 2 are implemented for quantess.im") if(is.character(Z)) { Z <- match.arg(Z, c("x", "y", "rad", "ang")) a <- qtPrepareCoordinate(Z, W, origin) Z <- a$Zfun Zrange <- a$Zrange } else Zrange <- NULL MZ <- harmonise(M=M, Z=Z) M <- MZ$M[W, drop=FALSE] Z <- MZ$Z[W, drop=FALSE] Zrange <- range(c(range(Z), Zrange)) Fun <- ewcdf(Z[], weights=M[]/sum(M[])) qZ <- quantile(Fun, probs=(1:(n-1))/n, type=type) qZ <- c(Zrange[1], qZ, Zrange[2]) ZC <- cut(Z, breaks=qZ, include.lowest=TRUE) out <- tess(image=ZC) tilenames(out) <- makeCutLabels(qZ, include.lowest=TRUE) if(!is.null(tcross)) out <- intersect.tess(out, tcross) return(out) } MinimalTess <- function(W, ...) { ## find the minimal tessellation of W consistent with the arguments argh <- list(...) v <- NULL if(length(argh)) { nama <- names(argh) known <- union(names(formals(quadrats)), names(formals(tess))) recognised <- !is.na(match(nama, known)) if(any(recognised)) { if(any(c("nx", "ny") %in% nama)) { v <- do.call(quadrats, resolve.defaults(list(X=quote(W)), argh[recognised], list(nx=1, ny=1))) } else if(any(c("xbreaks", "ybreaks") %in% nama)) { v <- do.call(quadrats, resolve.defaults(list(X=quote(W)), argh[recognised], list(xbreaks=W$xrange, ybreaks=W$yrange))) } else { v <- do.call(tess, resolve.defaults(argh[recognised], list(window=quote(W), keepempty=TRUE))) } } } return(v) } nestsplit <- function(X, ...) { stopifnot(is.ppp(X)) flist <- list(...) cansplit <- sapply(flist, inherits, what=c("factor", "tess", "owin", "im", "character")) splitted <- lapply(flist[cansplit], split, x=X) splitters <- lapply(splitted, attr, which="fsplit") if(any(!cansplit)) { extra <- do.call(MinimalTess, append(list(W=Window(X)), flist[!cansplit])) pos <- min(which(!cansplit)) ns <- length(splitters) if(pos > ns) { splitters <- append(splitters, list(extra)) } else { before <- splitters[seq_len(pos-1)] after <- splitters[pos:ns] splitters <- c(before, list(extra), after) } } ns <- length(splitters) if(ns == 0) return(X) if(ns == 1) return(split(X, splitters[[1]])) if(ns > 2) stop("Nesting depths greater than 2 are not yet implemented") names(splitters) <- good.names(names(splitters), paste0("f", 1:ns)) fax1 <- is.factor(sp1 <- splitters[[1]]) fax2 <- is.factor(sp2 <- splitters[[2]]) lev1 <- if(fax1) levels(sp1) else seq_len(sp1$n) lev2 <- if(fax2) levels(sp2) else seq_len(sp2$n) if(!fax1 && !fax2) { ## two tessellations marks(sp1) <- factor(lev1, levels=lev1) marks(sp2) <- factor(lev2, levels=lev2) sp12 <- intersect.tess(sp1, sp2, keepmarks=TRUE) pats <- split(X, sp12) f1 <- marks(sp12)[,1] f2 <- marks(sp12)[,2] } else { if(fax1 && fax2) { ## two grouping factors Xsp1 <- split(X, sp1) sp2.1 <- split(sp2, sp1) ll <- mapply(split, Xsp1, sp2.1, SIMPLIFY=FALSE) } else if(fax1 && !fax2) { ## grouping factor and tessellation Xsp1 <- split(X, sp1) ll <- lapply(Xsp1, split, f=sp2) } else if(!fax1 && fax2) { ## tessellation and grouping factor Xsp1 <- split(X, sp1) sp2.1 <- split(sp2, attr(Xsp1, "fgroup")) ll <- mapply(split, Xsp1, sp2.1, SIMPLIFY=FALSE) } neach <- lengths(ll) f1 <- rep(factor(lev1, levels=lev1), neach) f2 <- rep(factor(lev2, levels=lev2), length(Xsp1)) pats <- do.call(c, unname(ll)) } h <- hyperframe(pts=pats, f1=f1, f2=f2) names(h)[2:3] <- names(splitters) return(h) } spatstat.geom/R/plot.ppp.R0000644000176200001440000006601014636736026015163 0ustar liggesusers# # plot.ppp.R # # $Revision: 1.123 $ $Date: 2024/06/26 06:56:32 $ # # #-------------------------------------------------------------------------- plot.ppp <- function(x, main, ..., clipwin=NULL, chars=NULL, cols=NULL, use.marks=TRUE, which.marks=NULL, add=FALSE, type=c("p", "n"), legend=TRUE, leg.side=c("left", "bottom", "top", "right"), leg.args=list(), symap=NULL, maxsize=NULL, meansize=NULL, markscale=NULL, minsize=NULL, zerosize=NULL, zap=0.01, show.window=show.all, show.all=!add, do.plot=TRUE, multiplot=TRUE) { if(missing(main)) main <- short.deparse(substitute(x)) type <- match.arg(type) if(missing(legend)) legend <- (type == "p") if(clipped <- !is.null(clipwin)) { stopifnot(is.owin(clipwin)) W <- Window(x) clippy <- if(is.mask(W)) intersect.owin(W, clipwin) else edges(W)[clipwin] x <- x[clipwin] } else clippy <- NULL ## sensible default position legend <- legend && show.all if(legend) { leg.side <- match.arg(leg.side) vertical <- (leg.side %in% c("left", "right")) } ## ................................................................ ## Handle multiple columns of marks as separate plots ## (unless add=TRUE or which.marks selects a single column ## or multipage = FALSE) if(use.marks && is.data.frame(mx <- marks(x))) { implied.all <- is.null(which.marks) want.several <- implied.all || is.data.frame(mx <- mx[,which.marks]) do.several <- want.several && !add && multiplot if(do.several) { ## generate one plot for each column of marks y <- solapply(mx, setmarks, x=x) out <- do.call(plot, resolve.defaults(list(x=quote(y), main=main, show.window=show.window && !clipped, do.plot=do.plot, type=type, symap=symap), list(...), list(equal.scales=TRUE), list(panel.end=clippy), list(legend=legend, leg.side=leg.side, leg.args=leg.args), list(chars=chars, cols=cols, maxsize=maxsize, meansize=meansize, markscale=markscale, minsize=minsize, zerosize=zerosize, zap=zap))) return(invisible(out)) } if(is.null(which.marks)) { which.marks <- 1 if(do.plot) message("Plotting the first column of marks") } } ## ............... unmarked, or single column of marks .................... ## Determine symbol map and mark values to be used y <- x if(!is.marked(x, na.action="ignore") || !use.marks) { ## Marks are not mapped. marx <- NULL if(is.null(symap)) symap <- default.symbolmap(unmark(x), ..., chars=chars, cols=cols) } else { ## Marked point pattern marx <- marks(y, dfok=TRUE) if(is.data.frame(marx)) { ## select column or take first colum marx <- marx[, which.marks] y <- setmarks(y, marx) } if(npoints(y) > 0) { ok <- complete.cases(as.data.frame(y)) if(!any(ok)) { warning("All mark values are NA; plotting locations only.") if(is.null(symap)) symap <- default.symbolmap(unmark(x), ..., chars=chars, cols=cols) } else if(any(!ok)) { warning(paste("Some marks are NA;", "corresponding points are omitted.")) x <- x[ok] y <- y[ok] marx <- marks(y) } } ## apply default symbol map if(is.null(symap)) symap <- default.symbolmap(y, chars=chars, cols=cols, maxsize=maxsize, meansize=meansize, markscale=markscale, minsize=minsize, zerosize=zerosize, ...) } ## Determine bounding box for main plot BB <- as.rectangle(x) sick <- inherits(x, "ppp") && !is.null(rejects <- attr(x, "rejects")) if(sick) { ## Get relevant parameters par.direct <- list(main=main, use.marks=use.marks, maxsize=maxsize, meansize=meansize, markscale=markscale, minsize=minsize, zerosize=zerosize) par.rejects <- resolve.1.default(list(par.rejects=list(pch="+")), list(...)) par.all <- resolve.defaults(par.rejects, par.direct) rw <- resolve.defaults(list(...), list(rejectwindow=NULL))$rejectwindow ## determine window for rejects rwin <- if(is.null(rw)) rejects$window else if(is.logical(rw) && rw) rejects$window else if(inherits(rw, "owin")) rw else if(is.character(rw)) { switch(rw, box={boundingbox(rejects, x)}, ripras={ripras(c(rejects$x, x$x), c(rejects$y, x$y))}, stop(paste("Unrecognised option: rejectwindow=", rw))) } else stop("Unrecognised format for rejectwindow") if(is.null(rwin)) stop("Selected window for rejects pattern is NULL") BB <- boundingbox(BB, as.rectangle(rwin)) } ## Augment bounding box with space for legend, if appropriate legend <- legend && (symbolmaptype(symap) != "constant") if(legend) { leg.args <- append(list(side=leg.side, vertical=vertical), leg.args) if(isTRUE(leg.args$colour.only)) { ## only the colour map will be plotted ## use layout similar to plot.im sizeguess <- NULL leg.args <- resolve.defaults(leg.args, list(sep.frac=0.15, size.frac=0.05, las=1)) } else { ## symbols will be plotted ## guess maximum size of symbols maxsize <- invoke.symbolmap(symap, symbolmapdomain(symap), corners(as.rectangle(x)), add=add, do.plot=FALSE) sizeguess <- if(maxsize > 0) (1.5 * maxsize) else NULL } ## draw up layout layoutboxes <- do.call.matched(plan.legend.layout, append(list(B=quote(BB), size = sizeguess, started=FALSE, map=symap), leg.args)) ## bounding box for everything BB <- layoutboxes[["A"]] ## bounding box for legend legbox <- layoutboxes[["b"]] attr(symap, "legbox") <- legbox } ## return now if not plotting attr(symap, "bbox") <- BB if(!do.plot) return(invisible(symap)) ## ............. start plotting ....................... pt <- prepareTitle(main) main <- pt$main nlines <- pt$nlines blankmain <- if(nlines == 0) "" else rep(" ", nlines) dflt <- list(cex.main=1, xlim=NULL, ylim=NULL, ann=FALSE, axes=FALSE, xlab="", ylab="") rez <- resolve.defaults(list(...), dflt)[names(dflt)] do.call(plot.owin, append(list(x=quote(BB), type="n", add=add, main=blankmain, show.all=show.all), rez)) if(sick) { if(show.window) { ## plot windows if(!is.null(rw)) { ## plot window for rejects rwinpardefault <- list(lty=2,lwd=1,border=1) rwinpars <- resolve.defaults(par.rejects, rwinpardefault)[names(rwinpardefault)] dont.complain.about(rwin) do.call(plot.owin, append(list(quote(rwin), add=TRUE), rwinpars)) } ## plot window of main pattern if(!clipped) { xwindow <- x$window dont.complain.about(xwindow) do.call(plot.owin, resolve.defaults(list(quote(xwindow), add=TRUE), list(...), list(invert=TRUE))) } else plot(clippy, add=TRUE, ...) } if(type != "n") { ## plot reject points do.call(plot.ppp, append(list(quote(rejects), add=TRUE), par.all)) warning(paste(rejects$n, "illegal points also plotted")) } ## the rest is added add <- TRUE } ## Now convert to bona fide point pattern x <- as.ppp(x) xwindow <- x$window ## Plot observation window (or at least the main title) dont.complain.about(xwindow) do.call(plot.owin, resolve.defaults(list(x=quote(xwindow), add=TRUE, main=main, type=if(show.window && !clipped) "w" else "n", show.all=show.all), list(...), list(invert=TRUE))) ## If clipped, plot visible part of original window if(show.window && clipped) plot(clippy, add=TRUE, ...) # else if(show.all) fakemaintitle(as.rectangle(xwindow), main, ...) if(type != "n") { ## plot symbols ## invoke.symbolmap(symap, marx, x, add=TRUE) } ## add legend if(legend) { legendmap <- if(length(leg.args) == 0) symap else do.call(update, append(list(object=quote(symap)), leg.args)) dont.complain.about(legendmap) do.call(plot.symbolmap, append(list(x=quote(legendmap), main="", add=TRUE, xlim=legbox$xrange, ylim=legbox$yrange), leg.args)) } return(invisible(symap)) } ## determine symbol map for marks of points default.symbolmap.ppp <- local({ default.symbolmap.ppp <- function(x, ..., chars=NULL, cols=NULL, fixsize=FALSE, maxsize=NULL, meansize=NULL, markscale=NULL, minsize=NULL, zerosize=NULL, marktransform=NULL) { Y <- lapply(unstack(x), dsmEngine, ..., chars=chars, cols=cols, fixsize=fixsize, maxsize=maxsize, meansize=meansize, markscale=markscale, minsize=minsize, zerosize=zerosize, marktransform=marktransform) if(length(Y) == 1) Y <- Y[[1L]] return(Y) } ## full argument list dsmEngine <- function(x, ..., chars=NULL, cols=NULL, col=NULL, fixsize=FALSE, maxsize=NULL, meansize=NULL, markscale=NULL, minsize=NULL, zerosize=NULL, markrange=NULL, marklevels=NULL, marktransform=NULL) { marx <- marks(x) if(is.null(marx)) { ## null or constant symbol map ## consider using transparent colours if(is.null(cols) && is.null(col) && !any(c("fg", "bg") %in% names(list(...))) && (nx <- npoints(x)) > 100 && spatstat.options("transparent") && isTRUE(safeDevCapabilities()$semiTransparency)) cols <- rgb(0,0,0, default.transparency(nx)) if(!is.null(cols) && !is.null(col)) col <- NULL symap <- symbolmap(..., chars=chars, cols=cols, col=col) pnames <- symbolmapparnames(symap) if("shape" %in% pnames && !("size" %in% pnames)) { ## symbols require a size parameter m <- symbol.sizes.default(rep(1, npoints(x)), Window(x), maxsize=maxsize, meansize=meansize, minsize=minsize, zerosize=zerosize) symap <- update(symap, size=m) } return(symap) } if(!is.null(dim(marx))) stop("Internal error: multivariate marks in default.symap.points") ## understand user's wishes argnames <- names(list(...)) shapegiven <- "shape" %in% argnames chargiven <- (!is.null(chars)) || ("pch" %in% argnames) sizegiven <- ("size" %in% argnames) || (("cex" %in% argnames) && !shapegiven) assumecircles <- !(shapegiven || chargiven) sizeconstrained <- !all(sapply(list(maxsize, minsize, meansize, zerosize), is.null)) ## set defaults shapedefault <- if(!assumecircles) list() else list(shape="circles") ## pre-transformation of mark values transforming <- is.function(marktransform) && !fixsize Tmarx <- if(transforming) marktransform(marx) else marx transformedsizeargs <- list() if(transforming && sizegiven) { ## Given arguments 'size' or 'cex' ## are meant to apply to the transformed mark values. ## Insert the transformation if("size" %in% argnames) { siz <- list(...)$size if(is.function(siz)) { newsiz <- function(x, tra=marktransform, oldsize=siz) { oldsize(tra(x)) } transformedsizeargs$size <- newsiz } } if(("cex" %in% argnames) && !shapegiven) { cx <- list(...)$cex if(is.function(cx)) { newcex <- function(x, tra=marktransform, oldcex=cx) {oldcex(tra(x))} transformedsizeargs$cex <- newcex } } } if(inherits(marx, c("Date", "POSIXt"))) { ## ......... marks are dates or date/times ..................... timerange <- range(marx, na.rm=TRUE) if(sizegiven) { g <- do.call(symbolmap, resolve.defaults(list(range=timerange), transformedsizeargs, list(...), shapedefault, list(chars=chars, cols=cols))) return(g) } ## attempt to determine a scale for the marks if(transforming) stop("Argument marktransform is not yet supported for Date-time values") y <- scaletointerval(marx, 0, 1, timerange) y <- y[is.finite(y)] if(length(y) == 0) return(symbolmap(..., chars=chars, cols=cols)) scal <- mark.scale.default(y, as.owin(x), markrange=c(0,1), markscale=markscale, maxsize=maxsize, meansize=meansize, characters=chargiven) if(is.na(scal)) return(symbolmap(..., chars=chars, cols=cols)) ## scale determined sizefun <- function(x, scal=1, timerange=NULL) { (scal/2) * scaletointerval(x, 0, 1, timerange) } formals(sizefun)[[2]] <- scal ## ensures value of 'scal' is printed formals(sizefun)[[3]] <- timerange ## g <- do.call(symbolmap, resolve.defaults(list(range=timerange), list(...), shapedefault, list(size=sizefun))) return(g) } if(is.numeric(marx)) { ## ............. marks are numeric values ................... marx <- marx[is.finite(marx)] if(is.null(markrange)) { #' usual case if(length(marx) == 0) return(symbolmap(..., chars=chars, cols=cols)) markrange <- range(marx) } else { if(!all(inside.range(marx, markrange))) warning("markrange does not encompass the range of mark values", call.=FALSE) } ## if(sizegiven) { ## size function is given g <- do.call(symbolmap, resolve.defaults(list(range=markrange), transformedsizeargs, list(...), shapedefault, list(chars=chars, cols=cols))) return(g) } else if(fixsize) { ## require symbols of equal size ## determine fixed physical size if(!is.null(meansize)) { size <- meansize } else if(!is.null(minsize) && !is.null(maxsize)) { size <- (minsize+maxsize)/2 } else if(!is.null(minsize)) { size <- minsize } else if(!is.null(maxsize)) { size <- maxsize } else if(!is.null(zerosize) && zerosize > 0) { size <- zerosize } else { ## choose suitable size bb <- Frame(x) nn <- nndist(x) nn <- nn[nn > 0] size1 <- 1.4/sqrt(pi * length(marx)/area(bb)) size2 <- 0.07 * diameter(bb) size3 <- if(length(nn)) median(nn) else Inf size <- min(size1, size2, size3) } g <- do.call(symbolmap, resolve.defaults(list(range=markrange), list(...), list(size=size, chars=chars, cols=cols), shapedefault)) return(g) } ## attempt to determine a scale for the (transformed) marks if(transforming) { if(!is.numeric(Tmarx)) stop(paste("Function", sQuote("marktransform"), "should map numeric values to numeric values"), call.=FALSE) Tmarkrange <- range(Tmarx, marktransform(markrange)) } else Tmarkrange <- markrange ## degenerate? if(all(Tmarkrange == 0)) return(symbolmap(..., chars=chars, cols=cols)) ## try scaling scal <- mark.scale.default(Tmarx, as.owin(x), markrange=Tmarkrange, markscale=markscale, maxsize=maxsize, meansize=meansize, minsize=minsize, zerosize=zerosize, characters=chargiven) if(is.na(scal)) return(symbolmap(..., chars=chars, cols=cols)) ## scale determined zerosize <- attr(scal, "zerosize") %orifnull% 0 scal <- as.numeric(scal) if(Tmarkrange[1] >= 0) { ## all (transformed) marks are nonnegative cexfun <- function(x, scal=1, zerosize=0, tra=I) { zerosize + scal * tra(x) } circfun <- function(x, scal=1, zerosize=0, tra=I) { zerosize + scal * tra(x) } formals(cexfun)[[2]] <- formals(circfun)[[2]] <- scal formals(cexfun)[[3]] <- formals(circfun)[[3]] <- zerosize if(transforming) formals(cexfun)[[4]] <- formals(circfun)[[4]] <- marktransform sizedefault <- if(sizegiven) list() else if(chargiven) list(cex=cexfun) else list(size=circfun) } else { ## some marks are negative shapedefault <- if(!assumecircles) list() else list(shape=function(x) { ifelse(x >= 0, "circles", "squares") }) cexfun <- function(x, scal=1, zerosize=0, tra=I) { zerosize + scal * abs(tra(x)) } circfun <- function(x, scal=1, zerosize=0, tra=I) { zerosize + scal * abs(tra(x)) } formals(cexfun)[[2]] <- formals(circfun)[[2]] <- scal formals(cexfun)[[3]] <- formals(circfun)[[3]] <- zerosize if(transforming) formals(cexfun)[[4]] <- formals(circfun)[[4]] <- marktransform sizedefault <- if(sizegiven) list() else if(chargiven) list(cex=cexfun) else list(size=circfun) } g <- do.call(symbolmap, resolve.defaults(list(range=markrange), list(...), shapedefault, sizedefault, list(chars=chars, cols=cols))) return(g) } ## ........... non-numeric marks ......................... if(transforming) stop(paste("Argument", sQuote("marktransform"), "is not yet supported for non-numeric marks"), call.=FALSE) um <- marklevels %orifnull% if(is.factor(marx)) levels(marx) else sortunique(marx) ntypes <- length(um) if(!is.null(cols)) cols <- rep.int(cols, ntypes)[1:ntypes] if(shapegiven && sizegiven) { #' values mapped to symbols (shape and size specified) g <- symbolmap(inputs=um, ..., cols=cols) } else if(!shapegiven) { #' values mapped to 'pch' chars <- default.charmap(ntypes, chars) g <- symbolmap(inputs=um, ..., chars=chars, cols=cols) } else { #' values mapped to symbols of equal size #' determine size scal <- symbol.sizes.default(rep(1, npoints(x)), Window(x), maxsize=maxsize, meansize=meansize, minsize=minsize, zerosize=zerosize, characters=FALSE) g <- symbolmap(inputs=um, ..., size=scal, cols=cols) } return(g) } default.charmap <- function(n, ch=NULL) { if(!is.null(ch)) return(rep.int(ch, n)[1:n]) if(n <= 25) return(1:n) ltr <- c(letters, LETTERS) if(n <= 52) return(ltr[1:n]) ## wrapped sequence of letters warning("Too many types to display every type as a different character") return(ltr[1 + (0:(n - 1) %% 52)]) } default.transparency <- function(n) { if(n <= 100) 1 else (0.2 + 0.8 * exp(-(n-100)/1000)) } default.symbolmap.ppp }) ## utility function to determine mark scale ## (factor converting mark values to physical sizes on the plot) ## using a default rule mark.scale.default <- function(marx, w, ..., markrange=NULL, markscale=NULL, maxsize=NULL, meansize=NULL, minsize=NULL, zerosize=NULL, characters=FALSE) { ## establish values of parameters markscale, maxsize, meansize ngiven <- (!is.null(markscale)) + (!is.null(maxsize)) + (!is.null(meansize)) if(ngiven > 1) stop("Only one of the arguments markscale, maxsize, meansize", " should be given", call.=FALSE) if(ngiven == 0) { ## if ALL are absent, enforce the spatstat defaults ## (which could also be null) pop <- spatstat.options("par.points") markscale <- pop$markscale maxsize <- pop$maxsize meansize <- pop$meansize } ng <- (!is.null(minsize)) + (!is.null(zerosize)) if(ng > 1) stop("Arguments minsize and zerosize are incompatible", call.=FALSE) if(ng == 0) { pop <- spatstat.options("par.points") minsize <- pop$minsize zerosize <- pop$zerosize if(is.null(minsize) && is.null(zerosize)) zerosize <- 0 } if(!is.null(minsize)) stopifnot(minsize >= 0) ## determine range of absolute values of marks to be mapped absmarx <- abs(marx) ra <- range(absmarx) if(!is.null(markrange)) { check.range(markrange) ra <- range(ra, abs(markrange)) if(inside.range(0, markrange)) ra <- range(0, ra) } minabs <- ra[1L] maxabs <- ra[2L] ## determine linear map ## physical size = zerosize + scal * markvalue if(!is.null(markscale)) { ## mark scale is already given stopifnot(markscale > 0) scal <- markscale if(!is.null(minsize)) { ## required minimum physical size (of marks in range) is specified ## determine intercept 'zerosize' zerosize <- minsize - scal * ra[1L] } ## otherwise 'zerosize' is given or defaults to 0 } else { ## mark scale is to be determined from desired maximum/mean physical size if(!is.null(maxsize)) { stopifnot(maxsize > 0) } else if(!is.null(meansize)) { stopifnot(meansize > 0) } else { ## No prescriptions specified. ## Compute default value of 'maxsize' ## First guess appropriate max physical size of symbols bb <- as.rectangle(w) maxradius <- 1.4/sqrt(pi * length(marx)/area(bb)) maxsize <- 2 * min(maxradius, diameter(bb) * 0.07) } ## Examine mark values epsilon <- 4 * .Machine$double.eps if(maxabs < epsilon) return(NA) ## finally determine physical scale for symbols if(!is.null(maxsize)) { ## required maximum physical size (of marks in range) is specified if(!is.null(minsize)) { ## required minimum physical size (of marks in range) is specified ## map [minabs, maxabs] -> [minsize, maxsize] dv <- maxabs - minabs if(dv < epsilon) return(NA) scal <- (maxsize-minsize)/dv zerosize <- minsize - scal * minabs } else { ## minimum physical size not specified ## map [0, maxabs] to [zerosize, maxsize] ds <- maxsize - zerosize if(ds < epsilon) return(NA) scal <- ds/maxabs ## check minimum physical size is nonnegative if(zerosize + scal * minabs < 0) return(NA) } } else if(!is.null(meansize)) { ## required mean physical size (of marks in range) is specified meanabs <- mean(if(is.null(markrange)) absmarx else abs(markrange)) if(!is.null(minsize)) { ## required minimum physical size (of marks in range) is specified ## map {minabs, meanabs} -> {minsize, meansize} dm <- meanabs - minabs if(dm < epsilon) return(NA) scal <- (meansize-minsize)/dm zerosize <- minsize - scal * minabs } else { ## minimum physical size not specified ## map {0, meanabs} -> {zerosize, meansize} ds <- meansize - zerosize if(ds < epsilon || meanabs < epsilon) return(NA) scal <- ds/meanabs ## check minimum physical size is nonnegative if(zerosize + scal * minabs < 0) return(NA) } } else stop("internal error - neither maxsize nor meansize determined") if(characters) { ## when using characters ('pch') we need to ## convert physical sizes to 'cex' values charsize <- max(sidelengths(as.rectangle(w)))/40 scal <- scal/charsize zerosize <- zerosize/charsize } } attr(scal, "zerosize") <- zerosize return(scal) } ## utility function to determine symbol sizes using default rule symbol.sizes.default <- function(markvalues, ...) { scal <- mark.scale.default(markvalues, ...) if(is.na(scal)) return(NA) zerosize <- attr(scal, "zerosize") %orifnull% 0 scal <- as.numeric(scal) sizes <- zerosize + scal * markvalues return(sizes) } fakemaintitle <- function(bb, main, ...) { ## Try to imitate effect of 'title(main=main)' above a specified box if(!any(nzchar(main))) return(invisible(NULL)) bb <- as.rectangle(bb) x0 <- mean(bb$xrange) y0 <- bb$yrange[2] + length(main) * diff(bb$yrange)/12 parnames <- c('cex.main', 'col.main', 'font.main') parlist <- par(parnames) parlist <- resolve.defaults(list(...), parlist)[parnames] names(parlist) <- c('cex', 'col', 'font') do.call.matched(text.default, resolve.defaults(list(x=x0, y=y0, labels=main), parlist, list(...)), funargs=graphicsPars("text")) return(invisible(NULL)) } text.ppp <- function(x, ...) { graphics::text.default(x=x$x, y=x$y, ...) } spatstat.geom/R/distmap.R0000644000176200001440000001125414611065351015035 0ustar liggesusers# # # distmap.R # # $Revision: 1.34 $ $Date: 2023/08/28 06:38:54 $ # # # Distance transforms # # distmap <- function(X, ...) { UseMethod("distmap") } distmap.ppp <- function(X, ..., clip=FALSE, metric=NULL) { verifyclass(X, "ppp") if(!is.null(metric)) { ans <- invoke.metric(metric, "distmap.ppp", X=X, ..., clip=clip) return(ans) } e <- exactdt(X, ...) W <- e$w uni <- unitname(W) dmat <- e$d imat <- e$i V <- im(dmat, W$xcol, W$yrow, unitname=uni) I <- im(imat, W$xcol, W$yrow, unitname=uni) if(X$window$type == "rectangle") { # distance to frame boundary bmat <- e$b B <- im(bmat, W$xcol, W$yrow, unitname=uni) } else { ## distance to window boundary, not frame boundary bmat <- bdist.pixels(W, style="matrix") B <- im(bmat, W$xcol, W$yrow, unitname=uni) if(clip) { ## clip all to window V <- V[W, drop=FALSE] I <- I[W, drop=FALSE] B <- B[W, drop=FALSE] } } attr(V, "index") <- I attr(V, "bdry") <- B return(V) } distmap.owin <- function(X, ..., discretise=FALSE, invert=FALSE, connect=8, metric=NULL) { verifyclass(X, "owin") uni <- unitname(X) if(!is.null(metric)) { ans <- invoke.metric(metric, "distmap.owin", X=X, ..., discretise=discretise, invert=invert) return(ans) } if(is.empty(X)) { ## handle empty window Dist <- as.im(Inf, X) attr(Dist, "bdry") <- framedist.pixels(X, ...) return(Dist) } if(X$type == "rectangle") { M <- as.mask(X, ...) Bdry <- im(bdist.pixels(M, style="matrix"), M$xcol, M$yrow, unitname=uni) if(!invert) Dist <- as.im(M, value=0) else Dist <- Bdry } else if(X$type == "polygonal" && !discretise) { Edges <- edges(X) Dist <- distmap(Edges, ...) Bdry <- attr(Dist, "bdry") if(!invert) Dist[X] <- 0 else { bb <- as.rectangle(X) bigbox <- grow.rectangle(bb, diameter(bb)/4) Dist[complement.owin(X, bigbox)] <- 0 } } else { check.1.integer(connect) if(!(connect %in% c(8, 24))) stop("Argument 'connect' must equal 8 or 24", call.=FALSE) X <- as.mask(X, ...) if(invert) X <- complement.owin(X) xc <- X$xcol yr <- X$yrow nr <- X$dim[1L] nc <- X$dim[2L] ## pad out the input image with a margin of width 1 on all sides mat <- X$m mat <- cbind(FALSE, mat, FALSE) mat <- rbind(FALSE, mat, FALSE) ## call C routine res <- .C(SG_distmapbin, connect=as.integer(connect), xmin=as.double(xc[1L]), ymin=as.double(yr[1L]), xmax=as.double(xc[nc]), ymax=as.double(yr[nr]), nr = as.integer(nr), nc = as.integer(nc), inp = as.integer(as.logical(t(mat))), distances = as.double(matrix(0, ncol = nc + 2, nrow = nr + 2)), boundary = as.double(matrix(0, ncol = nc + 2, nrow = nr + 2)), PACKAGE="spatstat.geom") # strip off margins again dist <- matrix(res$distances, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)] bdist <- matrix(res$boundary, ncol = nc + 2, byrow = TRUE)[2:(nr + 1), 2:(nc +1)] # cast as image objects Dist <- im(dist, xc, yr, unitname=uni) Bdry <- im(bdist, xc, yr, unitname=uni) } attr(Dist, "bdry") <- Bdry return(Dist) } distmap.psp <- function(X, ..., extras=TRUE, clip=FALSE, metric=NULL) { verifyclass(X, "psp") if(!is.null(metric)) { ans <- invoke.metric(metric, "distmap.psp", X=X, ..., extras=extras, clip=clip) return(ans) } W <- Window(X) uni <- unitname(W) M <- as.mask(W, ...) ## handle empty pattern if(nsegments(X) == 0) { Dist <- as.im(Inf, W) if(extras) { Indx <- as.im(NA, W) Bdry <- bdist.pixels(M) if(clip) { Indx <- Indx[M, drop=FALSE] Bdry <- Bdry[M, drop=FALSE] } attr(Dist, "index") <- Indx attr(Dist, "bdry") <- Bdry } return(Dist) } rxy <- rasterxy.mask(M) xp <- rxy$x yp <- rxy$y E <- X$ends big <- 2 * diameter(Frame(W))^2 z <- NNdist2segments(xp, yp, E$x0, E$y0, E$x1, E$y1, big, wantindex=extras) xc <- M$xcol yr <- M$yrow Dist <- im(array(sqrt(z$dist2), dim=M$dim), xc, yr, unitname=uni) if(clip <- clip && !is.rectangle(W)) Dist <- Dist[M, drop=FALSE] if(extras) { Indx <- im(array(z$index, dim=M$dim), xc, yr, unitname=uni) Bdry <- im(bdist.pixels(M, style="matrix"), xc, yr, unitname=uni) if(clip) { Indx <- Indx[M, drop=FALSE] Bdry <- Bdry[M, drop=FALSE] } attr(Dist, "index") <- Indx attr(Dist, "bdry") <- Bdry } return(Dist) } spatstat.geom/R/layered.R0000644000176200001440000002652514611065352015031 0ustar liggesusers# # layered.R # # Simple mechanism for layered plotting # # $Revision: 1.40 $ $Date: 2022/01/04 05:30:06 $ # layered <- function(..., plotargs=NULL, LayerList=NULL) { argh <- list(...) if(length(argh) > 0 && !is.null(LayerList)) stop("LayerList is incompatible with other arguments") out <- if(!is.null(LayerList)) LayerList else argh n <- length(out) if(sum(nzchar(names(out))) != n) names(out) <- paste("Layer", seq_len(n)) if(is.null(plotargs)) { plotargs <- rep.int(list(list()), n) } else { if(!is.list(plotargs)) stop("plotargs should be a list of lists") if(!all(unlist(lapply(plotargs, is.list)))) plotargs <- list(plotargs) np <- length(plotargs) if(np == 1) plotargs <- rep(plotargs, n) else if(np != n) stop("plotargs should have one component for each element of the list") } names(plotargs) <- names(out) attr(out, "plotargs") <- plotargs class(out) <- c("layered", class(out)) return(out) } print.layered <- function(x, ...) { splat("Layered object") if(length(x) == 0) splat("(no entries)") for(i in seq_along(x)) { cat(paste("\n", names(x)[i], ":\n", sep="")) print(x[[i]]) } pl <- layerplotargs(x) hasplot <- (lengths(pl) > 0) if(any(hasplot)) splat("Includes plot arguments for", commasep(names(pl)[hasplot])) invisible(NULL) } plot.layered <- function(x, ..., which=NULL, plotargs=NULL, add=FALSE, show.all=!add, main=NULL, do.plot=TRUE) { if(is.null(main)) main <- short.deparse(substitute(x)) n <- length(x) if(!is.null(plotargs)) { np <- length(plotargs) if(!(is.list(plotargs) && all(unlist(lapply(plotargs, is.list))))) stop("plotargs should be a list of lists") } ## select layers if(!is.null(which)) { x <- x[which] nw <- length(x) if(!is.null(plotargs)) { if(np == n) plotargs <- plotargs[which] else if(np == 1) plotargs <- rep(plotargs, nw) else if(np != nw) stop("plotargs should have one component for each layer to be plotted") } n <- nw } else if(!is.null(plotargs)) { if(np == 1) plotargs <- rep(plotargs, n) else if(np != n) stop("plotargs should have one component for each layer") } ## remove null layers if(any(isnul <- unlist(lapply(x, is.null)))) { x <- x[!isnul] if(!is.null(plotargs)) plotargs <- plotargs[!isnul] n <- length(x) } ## anything to plot? if(n == 0) return(invisible(NULL)) ## Merge plotting arguments xplotargs <- layerplotargs(x) if(is.null(plotargs)) { plotargs <- xplotargs } else if(length(xplotargs) > 0) { for(i in 1:n) plotargs[[i]] <- resolve.defaults(plotargs[[i]], xplotargs[[i]]) } ## Determine bounding box a <- plotEachLayer(x, ..., plotargs=plotargs, add=add, show.all=show.all, do.plot=FALSE) if(!do.plot) return(a) bb <- as.rectangle(as.owin(a)) ## Start plotting if(!add && !is.null(bb)) { ## initialise new plot using bounding box pt <- prepareTitle(main) plot(bb, type="n", main=pt$blank) add <- TRUE } # plot the layers out <- plotEachLayer(x, ..., main=main, plotargs=plotargs, add=add, show.all=show.all, do.plot=TRUE) return(invisible(out)) } plotEachLayer <- function(x, ..., main, plotargs, add, show.all, do.plot=TRUE) { main.given <- !missing(main) ## do.plot=TRUE => plot the layers ## do.plot=FALSE => determine bounding boxes out <- boxes <- list() nama <- names(x) firstlayer <- TRUE for(i in seq_along(x)) { xi <- x[[i]] if(length(xi) == 0) { # null layer - no plotting out[[i]] <- boxes[[i]] <- NULL } else { ## plot layer i on top of previous layers if any. ## By default, ## - show all graphic elements of the first component only; ## - show title 'firstmain' on first component; ## - do not show any component names. add.i <- add || !firstlayer if(main.given) { main.i <- if(firstlayer) main else "" } else { show.all.i <- resolve.1.default(list(show.all=FALSE), list(...), plotargs[[i]]) main.i <- if(show.all.i) nama[i] else "" } dflt <- list(main=main.i, show.all=show.all && firstlayer) pla.i <- plotargs[[i]] defaultplot <- !(".plot" %in% names(pla.i)) ## plot layer i, or just determine bounding box if(defaultplot && inherits(xi, c("ppp", "psp", "owin", "lpp", "linnet", "im", "msr", "layered"))) { ## plot method for 'xi' has argument 'do.plot'. mplf <- if(inherits(xi, c("ppp", "lpp"))) list(multiplot=FALSE) else list() out[[i]] <- outi <- do.call(plot, resolve.defaults(list(x=quote(xi), add=add.i, do.plot=do.plot), list(...), mplf, pla.i, dflt)) boxes[[i]] <- as.rectangle(as.owin(outi)) } else { ## plot method for 'xi' does not have argument 'do.plot' if(do.plot) { if(defaultplot) { plotfun <- "plot" } else { plotfun <- pla.i[[".plot"]] pla.i <- pla.i[names(pla.i) != ".plot"] } out[[i]] <- outi <- do.call(plotfun, resolve.defaults(list(x=quote(xi), add=add.i), list(...), pla.i, dflt)) } ## convert layer i to box boxi <- try(as.rectangle(xi), silent=TRUE) boxes[[i]] <- if(!inherits(boxi, "try-error")) boxi else NULL } firstlayer <- FALSE } } ## one box to bound them all if(!all(unlist(lapply(boxes, is.null)))) attr(out, "bbox") <- do.call(boundingbox, boxes) return(out) } "[.layered" <- function(x, i, j, drop=FALSE, ...) { i.given <- !missing(i) && !is.null(i) j.given <- !missing(j) && !is.null(j) if(!i.given && !j.given) return(x) p <- attr(x, "plotargs") x <- unclass(x) nx <- length(x) if(i.given) { if(is.owin(i)) { #' spatial window subset nonemp <- (lengths(x) != 0) x[nonemp] <- lapply(x[nonemp], "[", i=i, ...) } else { #' vector subset index x <- x[i] p <- p[i] nx <- length(x) } } if(j.given) { nonemp <- (lengths(x) != 0) x[nonemp] <- lapply(x[nonemp], "[", i=j, ...) } if(drop && nx == 1) return(x[[1L]]) y <- layered(LayerList=x, plotargs=p) return(y) } "[[<-.layered" <- function(x, i, value) { x[i] <- if(!is.null(value)) list(value) else NULL return(x) } "[<-.layered" <- function(x, i, value) { p <- layerplotargs(x) ## invoke list method y <- x class(y) <- "list" y[i] <- value # make it a 'layered' object too class(y) <- c("layered", class(y)) # update names and plotargs if(any(blank <- !nzchar(names(y)))) { names(y)[blank] <- paste("Layer", which(blank)) pnew <- rep(list(list()), length(y)) names(pnew) <- names(y) m <- match(names(y), names(x)) mok <- !is.na(m) pnew[mok] <- p[m[mok]] layerplotargs(y) <- pnew } else layerplotargs(y) <- layerplotargs(x)[names(y)] return(y) } layerplotargs <- function(L) { stopifnot(inherits(L, "layered")) attr(L, "plotargs") } "layerplotargs<-" <- function(L, value) { if(!inherits(L, "layered")) L <- layered(L) if(!is.list(value)) stop("Replacement value should be a list, or a list-of-lists") n <- length(L) if(!all(unlist(lapply(value, is.list)))) value <- unname(rep(list(value), n)) if(length(value) != n) { if(length(value) == 1) value <- unname(rep(value, n)) else stop("Replacement value is wrong length") } if(is.null(names(value))) names(value) <- names(L) else if(!identical(names(value), names(L))) stop("Mismatch in names of list elements") attr(L, "plotargs") <- value return(L) } applytolayers <- function(L, FUN, ...) { # Apply FUN to each **non-null** layer, # preserving the plot arguments pla <- layerplotargs(L) if(length(L) > 0) { ok <- !unlist(lapply(L, is.null)) L[ok] <- lapply(L[ok], FUN, ...) } Z <- layered(LayerList=L, plotargs=pla) return(Z) } shift.layered <- function(X, vec=c(0,0), ...) { if(length(list(...)) > 0) { if(!missing(vec)) warning("Argument vec ignored; overridden by other arguments") ## ensure the same shift is applied to all layers s <- shift(X[[1L]], ...) vec <- getlastshift(s) } Y <- applytolayers(X, shift, vec=vec) attr(Y, "lastshift") <- vec return(Y) } affine.layered <- function(X, ...) { applytolayers(X, affine, ...) } rotate.layered <- function(X, ..., centre=NULL) { if(!is.null(centre)) { X <- shift(X, origin=centre) negorigin <- getlastshift(X) } else negorigin <- NULL Y <- applytolayers(X, rotate, ...) if(!is.null(negorigin)) Y <- shift(Y, -negorigin) return(Y) } reflect.layered <- function(X) { applytolayers(X, reflect) } flipxy.layered <- function(X) { applytolayers(X, flipxy) } scalardilate.layered <- function(X, ...) { applytolayers(X, scalardilate, ...) } rescale.layered <- function(X, s, unitname) { if(missing(s)) s <- NULL if(missing(unitname)) unitname <- NULL applytolayers(X, rescale, s=s, unitname=unitname) } as.owin.layered <- local({ as.owin.layered <- function(W, ..., fatal=TRUE) { if(length(W) == 0) { if(fatal) stop("Layered object is empty: no window data") return(NULL) } ## remove null layers isnul <- unlist(lapply(W, is.null)) W <- W[!isnul] if(length(W) == 0) { if(fatal) stop("Layered object has no window data") return(NULL) } Wlist <- lapply(unname(W), as.owin, ..., fatal=fatal) Wlist <- lapply(Wlist, rescue.rectangle) Wlist <- lapply(Wlist, puffbox) Z <- Wlist[[1L]] if(length(Wlist) > 1) { same <- unlist(lapply(Wlist[-1L], identical, y=Z)) if(!all(same)) Z <- do.call(union.owin, Wlist) } return(Z) } puffbox <- function(W) { ## union.owin will delete boxes that have width zero or height zero ## so 'puff' them out slightly ss <- sidelengths(Frame(W)) if(ss[1L] == 0) W$xrange <- W$xrange + 1e-6 * c(-1,1) * ss[2L] if(ss[2L] == 0) W$yrange <- W$yrange + 1e-6 * c(-1,1) * ss[1L] return(W) } as.owin.layered }) domain.layered <- Window.layered <- function(X, ...) { as.owin(X) } as.layered <- function(X) { UseMethod("as.layered") } as.layered.default <- function(X) { if(is.list(X) && all(sapply(X, is.sob))) layered(LayerList=X) else layered(X) } as.layered.ppp <- function(X) { if(!is.marked(X)) return(layered(X)) if(is.multitype(X)) return(layered(LayerList=split(X))) mX <- marks(X) if(!is.null(d <- dim(mX)) && d[2L] > 1) { mx <- as.data.frame(marks(X)) Y <- lapply(mx, setmarks, x=X) return(layered(LayerList=Y)) } return(layered(X)) } spatstat.geom/R/infline.R0000644000176200001440000001562614611065352015030 0ustar liggesusers# # infline.R # # Infinite lines # # $Revision: 1.29 $ $Date: 2024/02/04 08:04:51 $ # infline <- function(a=NULL, b=NULL, h=NULL, v=NULL, p=NULL, theta=NULL) { if(is.null(a) != is.null(b)) stop("invalid specification of a,b") if(is.null(p) != is.null(theta)) stop("invalid specification of p,theta") if(!is.null(h)) out <- data.frame(a=h, b=0, h=h, v=NA, p=h, theta=pi/2) else if(!is.null(v)) out <- data.frame(a=NA,b=NA,h=NA,v=v,p=v,theta=ifelseAB(v < 0, pi, 0)) else if(!is.null(a)) { # a, b specified z <- data.frame(a=a,b=b) a <- z$a b <- z$b theta <- ifelseAX(b == 0, pi/2, atan(-1/b)) theta <- theta %% pi p <- a * sin(theta) out <- data.frame(a=a, b=b, h=ifelseXB(b==0, a, NA), v=NA, p=p, theta=theta) } else if(!is.null(p)) { # p, theta specified z <- data.frame(p=p,theta=theta) p <- z$p theta <- z$theta theta <- theta %% (2*pi) if(any(reverse <- (theta >= pi))) { theta[reverse] <- theta[reverse] - pi p[reverse] <- -p[reverse] } vert <- (theta == 0) horz <- (cos(theta) == 0) gene <- !(vert | horz) v <- ifelseXB(vert, p, NA) h <- ifelseXB(horz, p, NA) a <- ifelseXB(gene, p/sin(theta), NA) b <- ifelseXB(gene, -cos(theta)/sin(theta), NA) out <- data.frame(a=a,b=b,h=h,v=v,p=p,theta=theta) } else stop("No data given!") class(out) <- c("infline", class(out)) return(out) } is.infline <- function(x) { inherits(x, "infline") } plot.infline <- function(x, ...) { for(i in seq_len(nrow(x))) { xi <- as.list(x[i, 1:4]) xi[sapply(xi, is.na)] <- NULL do.call(abline, append(xi, list(...))) } return(invisible(NULL)) } print.infline <- function(x, ...) { n <- nrow(x) splat(n, "infinite", ngettext(n, "line", "lines")) print(as.data.frame(x), ...) return(invisible(NULL)) } clip.infline <- function(L, win) { # clip a set of infinite straight lines to a window win <- as.owin(win) stopifnot(inherits(L, "infline")) nL <- nrow(L) if(nL == 0) return(psp(numeric(0),numeric(0),numeric(0),numeric(0), window=win)) seqL <- seq_len(nL) # determine circumcircle of win xr <- win$xrange yr <- win$yrange xmid <- mean(xr) ymid <- mean(yr) width <- diff(xr) height <- diff(yr) rmax <- sqrt(width^2 + height^2)/2 boundbox <- owinInternalRect(xmid + c(-1,1) * rmax, ymid + c(-1,1) * rmax) # convert line coordinates to origin (xmid, ymid) p <- L$p theta <- L$theta co <- cos(theta) si <- sin(theta) p <- p - xmid * co - ymid * si # compute intersection points with circumcircle hit <- (abs(p) < rmax) if(!any(hit)) return(psp(numeric(0),numeric(0),numeric(0),numeric(0), window=win)) p <- p[hit] theta <- theta[hit] q <- sqrt(rmax^2 - p^2) co <- co[hit] si <- si[hit] id <- seqL[hit] X <- psp(x0= xmid + p * co + q * si, y0= ymid + p * si - q * co, x1= xmid + p * co - q * si, y1= ymid + p * si + q * co, marks = factor(id, levels=seqL), window=boundbox, check=FALSE) # clip to window X <- X[win] return(X) } chop.tess <- function(X, L) { stopifnot(is.infline(L)) stopifnot(is.tess(X)||is.owin(X)) X <- as.tess(X) if(X$type == "image") { Xim <- X$image xr <- Xim$xrange yr <- Xim$yrange # extract matrices of pixel values and x, y coordinates Zmat <- as.integer(as.matrix(Xim)) xmat <- rasterx.im(Xim) ymat <- rastery.im(Xim) # process lines for(i in seq_len(nrow(L))) { # line i chops window into two pieces if(!is.na(h <- L[i, "h"])) { # horizontal line if(h > yr[1L] && h < yr[2L]) Zmat <- 2 * Zmat + (ymat > h) } else if(!is.na(v <- L[i, "v"])) { # vertical line if(v > xr[1L] && v < xr[2L]) Zmat <- 2 * Zmat + (xmat < v) } else { # generic line y = a + bx a <- L[i, "a"] b <- L[i, "b"] Zmat <- 2 * Zmat + (ymat > a + b * xmat) } } # Now just put back as factor image Zim <- im(Zmat, xcol=Xim$xcol, yrow=Xim$yrow, unitname=unitname(Xim)) Z <- tess(image=Zim) return(Z) } #---- polygonal computation -------- # get bounding box B <- as.rectangle(as.owin(X)) xr <- B$xrange yr <- B$yrange # get coordinates for(i in seq_len(nrow(L))) { # line i chops box B into two pieces if(!is.na(h <- L[i, "h"])) { # horizontal line if(h < yr[1L] || h > yr[2L]) Z <- NULL else { lower <- owinInternalRect(xr, c(yr[1L], h)) upper <- owinInternalRect(xr, c(h, yr[2L])) Z <- tess(tiles=list(lower,upper), window=B) } } else if(!is.na(v <- L[i, "v"])) { # vertical line if(v < xr[1L] || v > xr[2L]) Z <- NULL else { left <- owinInternalRect(c(xr[1L], v), yr) right <- owinInternalRect(c(v, xr[2L]), yr) Z <- tess(tiles=list(left,right), window=B) } } else { # generic line a <- L[i, "a"] b <- L[i, "b"] # Intersect with extended left and right sides of B yleft <- a + b * xr[1L] yright <- a + b * xr[2L] ylo <- min(yleft, yright, yr[1L]) - 1 yhi <- max(yleft, yright, yr[2L]) + 1 lower <- owin(poly=list(x=xr[c(1L,1L,2L,2L)], y=c(yleft,ylo,ylo,yright))) upper <- owin(poly=list(x=xr[c(1L,2L,2L,1L)], y=c(yleft,yright,yhi,yhi))) Bplus <- owinInternalRect(xr, c(ylo, yhi), unitname=unitname(B)) Z <- tess(tiles=list(lower,upper), window=Bplus) } # intersect this simple tessellation with X if(!is.null(Z)) { X <- intersect.tess(X, Z) tilenames(X) <- paste("Tile", seq_len(length(tiles(X)))) } } return(X) } whichhalfplane <- function(L, x, y=NULL) { verifyclass(L, "infline") xy <- xy.coords(x, y) x <- xy$x y <- xy$y m <- length(x) n <- nrow(L) Z <- matrix(as.logical(NA_integer_), n, m) for(i in seq_len(n)) { if(!is.na(h <- L[i, "h"])) { #' horizontal line Z[i,] <- (y < h) } else if(!is.na(v <- L[i, "v"])) { #' vertical line Z[i,] <- (x < v) } else { #' generic line y = a + bx a <- L[i, "a"] b <- L[i, "b"] Z[i,] <- (y < a + b * x) } } return(Z) } rotate.infline <- function(X, angle=pi/2, ...) { if(nrow(X) == 0) return(X) Y <- with(X, infline(p = p, theta=theta + angle)) return(Y) } shift.infline <- function(X, vec=c(0,0), ...) { if(nrow(X) == 0) return(X) vec <- as2vector(vec) Y <- with(X, infline(p = p + vec[1L] * cos(theta) + vec[2L] * sin(theta), theta=theta)) return(Y) } reflect.infline <- function(X) { if(nrow(X) == 0) return(X) Y <- with(X, infline(p = p, theta=(theta + pi) %% (2 * pi))) return(Y) } flipxy.infline <- function(X) { if(nrow(X) == 0) return(X) Y <- with(X, infline(p = p, theta=(pi/2 - theta) %% (2 * pi))) return(Y) } spatstat.geom/R/solist.R0000644000176200001440000001565014633446111014716 0ustar liggesusers## ## solist.R ## ## Methods for class `solist' (spatial object list) ## ## and related classes 'anylist', 'ppplist', 'imlist', 'linimlist' ## ## plot.solist is defined in plot.solist.R ## ## $Revision: 1.29 $ $Date: 2024/06/16 02:20:05 $ anylist <- function(...) { x <- list(...) class(x) <- c("anylist", "listof", class(x)) return(x) } print.anylist <- function (x, ...) { ll <- length(x) if(ll == 0) { splat("(Zero length list)") return(invisible(NULL)) } nn <- names(x) if (length(nn) != ll) nn <- paste("Component", seq.int(ll)) spaceok <- waxlyrical('space') for (i in seq_len(ll)) { splat(paste0(nn[i], ":")) print(x[[i]], ...) if(spaceok && i < ll) cat("\n") } return(invisible(NULL)) } as.anylist <- function(x) { if(inherits(x, "anylist")) return(x) if(!is.list(x)) x <- list(x) class(x) <- c("anylist", "listof", class(x)) return(x) } "[.anylist" <- function(x, i, ...) { cl <- oldClass(x) ## invoke list method y <- NextMethod("[") if(length(y) == 0) return(list()) class(y) <- cl return(y) } "[<-.anylist" <- function(x, i, value) { as.anylist(NextMethod("[<-")) } summary.anylist <- function(object, ...) { as.anylist(lapply(object, summary, ...)) } ## .................... solist ............................. is.sob <- local({ ## test whether x is a spatial object suitable for solist sobjectclasses <- c("ppp", "psp", "im", "owin", "quad", "tess", "msr", "quadratcount", "quadrattest", "layered", "funxy", "distfun", "nnfun", "lpp", "linnet", "linfun", "lintess", "influence.ppm", "leverage.ppm") ## Note 'linim' inherits 'im' ## 'dfbetas.ppm' inherits 'msr' ## diagram objects typically inherit 'ppp' is.sob <- function(x) { inherits(x, what=sobjectclasses) } is.sob }) solist <- function(..., check=TRUE, promote=TRUE, demote=FALSE, .NameBase) { stuff <- list(...) if(length(stuff) && !missing(.NameBase) && !any(nzchar(names(stuff)))) names(stuff) <- paste(.NameBase, seq_along(stuff)) if((check || demote) && !all(sapply(stuff, is.sob))) { if(demote) return(as.anylist(stuff)) stop("Some arguments of solist() are not 2D spatial objects") } class(stuff) <- unique(c("solist", "anylist", "listof", class(stuff))) if(promote) { if(all(sapply(stuff, is.ppp))) { class(stuff) <- c("ppplist", class(stuff)) } else if(all(sapply(stuff, is.im))) { class(stuff) <- c("imlist", class(stuff)) if(all(sapply(stuff, is.linim))) class(stuff) <- c("linimlist", class(stuff)) } } return(stuff) } as.solist <- function(x, ...) { if(inherits(x, "solist") && length(list(...)) == 0) { #' wipe superfluous info if(inherits(x, "ppplist")) attributes(x)[c("fsplit", "fgroup")] <- NULL class(x) <- c("solist", "anylist", "listof") return(x) } #' needs to be enclosed in list() ? if(!is.list(x) || (is.sob(x) && !inherits(x, "layered"))) x <- list(x) return(do.call(solist, append(x, list(...)))) } is.solist <- function(x) inherits(x, "solist") print.solist <- function (x, ...) { what <- if(inherits(x, "ppplist")) "point patterns" else if(inherits(x, "linimlist")) "pixel images on a network" else if(inherits(x, "imlist")) "pixel images" else "spatial objects" splat(paste("List of", what)) parbreak() NextMethod("print") } "[.solist" <- function(x, i, ...) { cl <- oldClass(x) if(!missing(i) && is.owin(i)) { ## spatial subset y <- lapply(unclass(x), "[", i=i, ...) } else { ## invoke list method y <- NextMethod("[") } if(length(y) == 0) return(list()) class(y) <- cl return(y) } "[<-.solist" <- function(x, i, value) { ## invoke list method y <- NextMethod("[<-") ## check again return(do.call(solist, y)) } summary.solist <- function(object, ...) { x <- lapply(object, summary, ...) attr(x, "otype") <- if(inherits(object, "ppplist")) "ppp" else if(inherits(object, "linimlist")) "im" else "" if(inherits(object, "imlist")) "im" else "" class(x) <- c("summary.solist", "anylist") x } print.summary.solist <- function(x, ...) { what <- switch(attr(x, "otype"), ppp="point patterns", im="pixel images", "spatial objects") splat("Summary of", length(x), what) parbreak() NextMethod("print") } as.layered.solist <- function(X) { layered(LayerList=X) } #' ----- ppplist and imlist methods ---------------------------- as.data.frame.ppplist <- local({ rnf <- function(x) { n <- nrow(x) if(n > 0) row.names(x) <- paste("Point", seq_len(n)) return(x) } as.data.frame.ppplist <- function(x, row.names = NULL, ...) { y <- lapply(lapply(x, as.data.frame.ppp), rnf) if(is.null(row.names)) { #' work around a quirk of 'rbind' singleton <- (sapply(y, nrow) == 1) if(any(singleton)) names(y)[singleton] <- paste0(names(x)[singleton], ".Point 1") } z <- do.call(rbind, y) if(!is.null(row.names)) row.names(z) <- row.names return(z) } as.data.frame.ppplist }) #' ----- ppplist and imlist ---------------------------- #' for efficiency only as.ppplist <- function(x, check=TRUE) { if(check) { x <- as.solist(x, promote=TRUE, check=TRUE) if(!inherits(x, "ppplist")) stop("some entries are not point patterns") } class(x) <- unique(c("ppplist", "solist", "anylist", "listof", class(x))) return(x) } is.ppplist <- function(x) inherits(x, "ppplist") as.imlist <- function(x, check=TRUE) { if(check) { x <- as.solist(x, promote=TRUE, check=TRUE) if(!inherits(x, "imlist")) stop("some entries are not images") } else { #' just apply required classes, in required order reqd <- c("imlist", "solist", "anylist", "listof") class(x) <- unique(c(reqd, class(x))) } return(x) } is.imlist <- function(x) inherits(x, "imlist") as.linimlist <- function(x, check=TRUE) { x <- as.imlist(x, check=check) if(check) { if(!all(sapply(x, is.linim))) stop("All entries must be pixel images on a network") } class(x) <- unique(c("linimlist", class(x))) return(x) } # --------------- counterparts of 'lapply' -------------------- anylapply <- function(X, FUN, ...) { v <- lapply(X, FUN, ...) return(as.anylist(v)) } solapply <- function(X, FUN, ..., check=TRUE, promote=TRUE, demote=FALSE) { v <- lapply(X, FUN, ...) u <- as.solist(v, check=check, promote=promote, demote=demote) return(u) } expandSpecialLists <- function(x, special="solist") { ## x is a list which may include entries which are lists, of class 'special' ## unlist these entries only hit <- sapply(x, inherits, what=special) if(!any(hit)) return(x) # wrap each *non*-special entry in list() x[!hit] <- lapply(x[!hit], list) # now strip one layer of list() from all entries return(unlist(x, recursive=FALSE)) } spatstat.geom/R/colourtools.R0000644000176200001440000001277714611065351015773 0ustar liggesusers# # colourtools.R # # $Revision: 1.22 $ $Date: 2022/01/04 05:30:06 $ # rgb2hex <- function(v, maxColorValue=255) { stopifnot(is.numeric(v)) if(!is.matrix(v)) v <- matrix(v, nrow=1L) if(ncol(v) %in% c(3, 4)) { out <- rgb(v, maxColorValue=maxColorValue) return(out) } stop("v should be a vector of length 3 or 4, or a matrix with 3 or 4 columns") } rgb2hsva <- function(red, green=NULL, blue=NULL, alpha=NULL, maxColorValue=255) { if(is.null(green) && is.null(blue) && is.null(alpha)) { ## red should be a 3-row matrix of RGB values ## or a 4-row matrix of RGBA values if(!is.matrix(red)) red <- matrix(red, ncol=1L) ## check for an alpha channel if(nrow(red) == 4) { alpha <- red[4L,] red <- red[-4L, , drop=FALSE] } } y <- rgb2hsv(red, green, blue, maxColorValue=maxColorValue) if(!is.null(alpha)) y <- rbind(y, alpha=alpha/maxColorValue) return(y) } col2hex <- function(x) { # convert to RGBA y <- col2rgb(x, alpha=TRUE) # remove alpha channel if all colours are opaque if(all(y["alpha", ] == 255)) y <- y[1:3, , drop=FALSE] # convert to hex z <- rgb2hex(t(y)) return(z) } paletteindex <- function(x) { x <- col2hex(x) p <- col2hex(palette()) m <- match(x, p) return(m) } is.colour <- function(x) { if(length(x) == 0) return(FALSE) cx <- try(col2rgb(x), silent=TRUE) bad <- inherits(cx, "try-error") return(!bad) } samecolour <- function(x, y) { col2hex(x) == col2hex(y) } complementarycolour <- function(x) { if(is.null(x)) return(NULL) if(inherits(x, "colourmap")) { colouroutputs(x) <- complementarycolour(colouroutputs(x)) return(x) } # convert to RGBA y <- col2rgb(x, alpha=TRUE) # complement of R, G, B y[1:3, ] <- 255 - y[1:3, ] # convert to colours z <- rgb2hex(t(y)) return(z) } is.grey <- function(x) { if(inherits(x, "colourmap")) x <- colouroutputs(x) if(is.function(x)) return(NA) y <- rgb2hsva(col2rgb(x, alpha=TRUE)) sat <- y["s", ] alp <- y["alpha", ] return(sat == 0 & alp == 1) } to.opaque <- function(x) { if(all(!is.na(paletteindex(x)))) return(x) # preserve palette colours rgb(t(col2rgb(x)), maxColorValue=255) } to.transparent <- function(x, fraction) { if(all(fraction == 1)) return(to.opaque(x)) rgb(t(col2rgb(x))/255, alpha=fraction, maxColorValue=1) } to.saturated <- function(x, s=1) { y <- rgb2hsv(col2rgb(x)) ## map grey to black, otherwise saturate the colour notwhite <- !(y["h",] == 0 & y["s",] == 0 & y["v", ] == 1) isgrey <- (y["s", ] == 0) y["v", isgrey & notwhite] <- 0 y["s", !isgrey & notwhite] <- s ## convert back z <- hsv(y["h",], y["s",], y["v",]) return(z) } to.grey <- function(x, weights=c(0.299, 0.587, 0.114), transparent=FALSE) { if(is.null(x)) return(NULL) if(inherits(x, "colourmap")) { colouroutputs(x) <- to.grey(colouroutputs(x), weights=weights, transparent=transparent) return(x) } if(is.function(x)) { f <- x g <- function(...) to.grey(f(...), weights=weights, transparent=transparent) return(g) } ## preserve palette indices, if only using black/grey if(all(!is.na(paletteindex(x))) && all(is.grey(x))) return(x) if(!transparent) { y <- col2rgb(x) g <- (weights %*% y)/(255 * sum(weights)) z <- grey(g) } else { yy <- col2rgb(x, alpha=TRUE) y <- yy[1:3, , drop=FALSE] g <- (weights %*% y)/(255 * sum(weights)) z <- grey(g, alpha=yy[4L,]/255.0) } return(z) } is.col.argname <- function(x) { return(nzchar(x) & ((x == "col") | (substr(x, 1L, 4L) == "col."))) } col.args.to.grey <- function(x, ...) { if(any(hit <- is.col.argname(names(x)))) x[hit] <- lapply(x[hit], to.grey, ...) return(x) } # versions of rgb() and hsv() that work with NA values rgbNA <- function(red, green, blue, alpha=NULL, maxColorValue=1) { df <- if(is.null(alpha)) data.frame(red=red, green=green, blue=blue) else data.frame(red=red, green=green, blue=blue, alpha=alpha) result <- rep(NA_character_, nrow(df)) ok <- complete.cases(df) result[ok] <- if(is.null(alpha)) { with(df, rgb(red[ok], green[ok], blue[ok], maxColorValue=maxColorValue)) } else { with(df, rgb(red[ok], green[ok], blue[ok], alpha[ok], maxColorValue=maxColorValue)) } return(result) } hsvNA <- function(h, s, v, alpha=NULL) { df <- if(is.null(alpha)) data.frame(h=h, s=s, v=v) else data.frame(h=h, s=s, v=v, alpha=alpha) result <- rep(NA_character_, nrow(df)) ok <- complete.cases(df) result[ok] <- if(is.null(alpha)) { with(df, hsv(h[ok], s[ok], v[ok])) } else { with(df, hsv(h[ok], s[ok], v[ok], alpha[ok])) } return(result) } ## This function traps the colour arguments ## and converts to greyscale if required. do.call.plotfun <- function(fun, arglist, ..., envir=parent.frame()) { if(spatstat.options("monochrome")) { keys <- names(arglist) if(!is.null(keys)) { cols <- nzchar(keys) & ((keys %in% c("border", "col", "fg", "bg")) | (substr(keys, 1, 4) == "col.")) if(any(cols)) arglist[cols] <- lapply(arglist[cols], to.grey) } } do.call.matched(fun, arglist, ..., envir=envir) } gammabreaks <- function(ra, n, gamma=1) { # make breaks for x which are evenly spaced on the scale y = x^gamma check.1.real(gamma) stopifnot(gamma > 0) y <- seq(from=0, to=1, length.out=n) breaks <- ra[1L] + diff(ra) * y^(1/gamma) breaks[1L] <- ra[1L] breaks[n] <- ra[2L] return(breaks) } spatstat.geom/R/bufftess.R0000644000176200001440000000324314611065351015214 0ustar liggesusers#' #' bufftess.R #' #' Buffer (Distance) Tessellation #' #' $Revision: 1.3 $ $Date: 2022/03/31 09:05:10 $ #' #' Copyright (c) 2021 Adrian Baddeley, Ege Rubak and Rolf Turner #' GNU Public Licence >= 2.0 bufftess <- function(X, breaks, W=Window(X), ..., polygonal=TRUE) { breaks <- as.numeric(breaks) Wgiven <- !missing(W) if(!polygonal || length(breaks) == 1L) { ## Determine break points from distance values in distmap D <- distmap(X, ...) if(Wgiven) D <- D[W, drop=FALSE] drange <- c(0, range(D)) breaks <- exactCutBreaks(drange, breaks) ## ensure break points are nonzero breaks <- unique(pmax(0, breaks)) } if(!polygonal) { ## pixel image tessellation G <- cut(x=D, breaks=breaks, ...) Y <- tess(image=G) attr(Y, "breaks") <- breaks return(Y) } else { ## polygonal tiles tessellation W <- as.polygonal(W) dbig <- diameter(Frame(W)) nbreaks <- length(breaks) nbands <- nbreaks - 1L Ytiles <- vector(mode="list", length=nbands) for(ibreak in seq_len(nbreaks)) { d <- breaks[ibreak] #' dilation if(d > dbig) { B <- W } else if(d > 0) { B <- dilation(X, d, polygonal=TRUE) B <- intersect.owin(B, W) } else { B <- NULL } #' set difference if(ibreak == 1L) { Bprev <- Bmin <- B } else { iband <- ibreak - 1L Ytiles[[iband]] <- setminus.owin(B, Bprev) Bprev <- B } } names(Ytiles) <- levels(cut(breaks, breaks, ...)) Wfinal <- rescue.rectangle(setminus.owin(B, Bmin)) Y <- tess(tiles=Ytiles, window=Wfinal) attr(Y, "breaks") <- breaks return(Y) } } spatstat.geom/R/boundingcircle.R0000644000176200001440000000246014611065351016362 0ustar liggesusers#' #' boundingcircle.R #' #' bounding circle and its centre #' #' $Revision: 1.6 $ $Date: 2017/06/05 10:31:58 $ #' circumradius <- function(x, ...) { .Deprecated("boundingradius") UseMethod("boundingradius") } circumradius.owin <- function(x, ...) { .Deprecated("boundingradius.owin") boundingradius.owin(x, ...) } circumradius.ppp <- function(x, ...) { .Deprecated("boundingradius.ppp") boundingradius.ppp(x, ...) } boundingradius <- function(x, ...) { UseMethod("boundingradius") } boundingcentre <- function(x, ...) { UseMethod("boundingcentre") } boundingcircle <- function(x, ...) { UseMethod("boundingcircle") } #' owin boundingradius.owin <- function(x, ...) { sqrt(min(fardist(x, ..., squared=TRUE))) } boundingcentre.owin <- function(x, ...) { z <- where.min(fardist(x, ..., squared=TRUE)) Window(z) <- x return(z) } boundingcircle.owin <- function(x, ...) { d2 <- fardist(x, ..., squared=TRUE) z <- where.min(d2) r <- sqrt(min(d2)) w <- disc(centre=z, radius=r) return(w) } #' ppp boundingradius.ppp <- function(x, ...) { boundingradius(convexhull(x), ...) } boundingcentre.ppp <- function(x, ...) { z <- boundingcentre(convexhull(x), ...) Window(z) <- Window(x) return(z) } boundingcircle.ppp <- function(x, ...) { boundingcircle(convexhull(x), ...) } spatstat.geom/R/Math.imlist.R0000644000176200001440000000333014611065351015561 0ustar liggesusers## ## Math.imlist.R ## ## $Revision: 1.7 $ $Date: 2020/10/31 05:06:19 $ ## Math.imlist <- function(x, ...){ solapply(x, .Generic, ...) } Complex.imlist <- function(z){ solapply(z, .Generic) } Summary.imlist <- function(..., na.rm=TRUE){ argh <- expandSpecialLists(list(...)) if(length(names(argh)) > 0) { isim <- sapply(argh, is.im) names(argh)[isim] <- "" } do.call(.Generic, c(argh, list(na.rm=na.rm))) } #' Due to the dispatch mechanism, Ops.im and Ops.imlist must be identical #' if we want to handle combinations of imlist and im. #' (See 'Math.im.R' for the definition of 'imageOp') Ops.imlist <- Ops.im <- function(e1,e2=NULL){ imagelistOp(e1, e2, .Generic) } imagelistOp <- function(e1, e2=NULL, op) { if(is.null(e2)) { #' unary operation result <- if(is.im(e1)) imageOp(e1, op=op) else solapply(e1, imageOp, op=op) return(result) } #' binary operation single1 <- !inherits(e1, c("imlist", "solist")) single2 <- !inherits(e2, c("imlist", "solist")) if(single1 && single2) return(imageOp(e1, e2, op)) if(single1 && !single2) { e1list <- rep(list(e1), length(e2)) e2list <- e2 outnames <- names(e2) } else if(!single1 && single2) { e1list <- e1 e2list <- rep(list(e2), length(e1)) outnames <- names(e1) } else { e1list <- e1 e2list <- e2 if(length(e1) != length(e2)) stop(paste("Lists of images have incompatible lengths:", length(e1), "!=", length(e2)), call.=FALSE) outnames <- names(e1) %orifnull% names(e2) } #' compute v <- mapply(imageOp, e1=unname(e1list), e2=unname(e2list), MoreArgs=list(op=op), SIMPLIFY=FALSE) names(v) <- outnames return(as.solist(v)) } spatstat.geom/R/metricPdt.R0000644000176200001440000000712714611065352015334 0ustar liggesusers#' #' metricPdt.R #' #' Metric distance transform of pixel mask #' #' $Revision: 1.9 $ $Date: 2022/05/21 09:52:11 $ rectdistmap <- function(X, asp=1.0, npasses=1, verbose=FALSE) { w <- as.mask(X) check.1.real(asp) check.1.integer(npasses) stopifnot(asp > 0) #' ensure grid has suitable aspect ratio dx <- w$xstep dy <- w$ystep a <- dy/(asp*dx) if(verbose) splat("grid aspect", signif(a, 3)) refined <- (a > 1.2 || a < 0.8) if(refined) { flipped <- (a < 1) if(flipped) a <- 1/a n <- if(a > 10) 1 else if(a > 6) 2 else if(a > 4) 4 else 12 an <- if(n > 1) round(a * n) else ceiling(a) k <- c(an, n)/greatest.common.divisor(an, n) if(flipped) k <- rev(k) woriginal <- w w <- as.owin(w, dimyx=k * dim(w)) if(verbose) { splat("Grid expansion", k[1], "x", k[2]) splat("Adjusted grid aspect", (a * k[2])/k[1]) } } #' nr <- w$dim[1L] nc <- w$dim[2L] xcol <- w$xcol yrow <- w$yrow #' input image will be padded out with a margin of width 2 on all sides mr <- mc <- 2L #' full dimensions of padded image Nnr <- nr + 2 * mr Nnc <- nc + 2 * mc N <- Nnr * Nnc #' output image (subset): rows & columns (R indexing) rmin <- mr + 1L rmax <- Nnr - mr cmin <- mc + 1L cmax <- Nnc - mc #' do padding x <- matrix(FALSE, nrow=Nnr, ncol=Nnc) x[rmin:rmax, cmin:cmax] <- w$m #' compute distmap res <- .C(SG_mdtPOrect, as.double(xcol[1L]), as.double(yrow[1L]), as.double(xcol[nc]), as.double(yrow[nr]), nr = as.integer(nr), nc = as.integer(nc), mr = as.integer(mr), mc = as.integer(mc), inp = as.integer(t(x)), asp = as.double(asp), npasses = as.integer(npasses), distances = as.double (double(N)), rows = as.integer(integer(N)), cols = as.integer(integer(N)), PACKAGE="spatstat.geom") dist <- matrix(res$distances, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] result <- as.im(dist, w) if(refined) result <- as.im(result, W=woriginal) # rows <- matrix(res$rows, # ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] # cols <- matrix(res$cols, # ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] # convert from C to R indexing # rows <- rows + 1L - as.integer(mr) # cols <- cols + 1L - as.integer(mc) # return(list(d=dist,row=rows,col=cols,b=bdist, w=w)) edge <- TRUE if(edge) { #' calculate distance transform to boundary y <- x y[] <- TRUE y[rmin:rmax, cmin:cmax] <- FALSE y[rmin, ] <- TRUE y[rmax, ] <- TRUE y[, cmin] <- TRUE y[, cmax] <- TRUE #' compute distmap bres <- .C(SG_mdtPOrect, as.double(xcol[1L]), as.double(yrow[1L]), as.double(xcol[nc]), as.double(yrow[nr]), nr = as.integer(nr), nc = as.integer(nc), mr = as.integer(mr), mc = as.integer(mc), inp = as.integer(t(y)), asp = as.double(asp), npasses = as.integer(npasses), distances = as.double (double(N)), rows = as.integer(integer(N)), cols = as.integer(integer(N)), PACKAGE="spatstat.geom") bdist <- matrix(bres$distances, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] bdist <- as.im(bdist, w) if(refined) bdist <- as.im(bdist, W=woriginal) attr(result, "bdist") <- bdist } return(result) } spatstat.geom/R/window.R0000644000176200001440000012364614755007277014730 0ustar liggesusers# # window.S # # A class 'owin' to define the "observation window" # # $Revision: 4.213 $ $Date: 2025/02/16 00:03:14 $ # # # A window may be either # # - rectangular: # a rectangle in R^2 # (with sides parallel to the coordinate axes) # # - polygonal: # delineated by 0, 1 or more non-self-intersecting # polygons, possibly including polygonal holes. # # - digital mask: # defined by a binary image # whose pixel values are TRUE wherever the pixel # is inside the window # # Any window is an object of class 'owin', # containing at least the following entries: # # $type: a string ("rectangle", "polygonal" or "mask") # # $xrange # $yrange # vectors of length 2 giving the real dimensions # of the enclosing box # $units # name of the unit of length # # The 'rectangle' type has only these entries. # # The 'polygonal' type has an additional entry # # $bdry # a list of polygons. # Each entry bdry[[i]] determines a closed polygon. # # bdry[[i]] has components $x and $y which are # the cartesian coordinates of the vertices of # the i-th boundary polygon (without repetition of # the first vertex, i.e. same convention as in the # plotting function polygon().) # # # The 'mask' type has entries # # $m logical matrix # $dim its dimension array # $xstep,ystep x and y dimensions of a pixel # $xcol vector of x values for each column # $yrow vector of y values for each row # # (the row index corresponds to increasing y coordinate; # the column index " " " " " " x " " ".) # # #----------------------------------------------------------------------------- # .Spatstat.Image.Warning <- c("Row index corresponds to increasing y coordinate; column to increasing x", "Transpose matrices to get the standard presentation in R", "Example: image(result$xcol,result$yrow,t(result$d))") owin <- function(xrange=c(0,1), yrange=c(0,1), ..., poly=NULL, mask=NULL, unitname=NULL, xy=NULL) { ## trap a common abuse of syntax: owin(window) if(nargs() == 1 && !missing(xrange) && is.owin(xrange)) return(xrange) ## parse poly.given <- !is.null(poly) mask.given <- !is.null(mask) range.given <- !missing(xrange) || !missing(yrange) if(range.given) { if(missing(xrange) != missing(yrange)) stop("If one of xrange, yrange is specified then both must be.") xrange <- unname(xrange) yrange <- unname(yrange) } if(poly.given && mask.given) stop("Ambiguous -- both polygonal boundary and digital mask supplied") if(!mask.given && !is.null(xy)) warning("Argument xy ignored: it is only applicable when a mask is given") if(poly.given) { ## convert data frames to vanilla lists if(is.data.frame(poly)) poly <- as.list(poly) else if(is.list(poly) && any(unlist(lapply(poly, is.data.frame)))) poly <- lapply(poly, as.list) } if(!poly.given && !mask.given) { ## rectangular window owinInternalRect(xrange, yrange, ..., unitname=unitname) } else if(poly.given) { ## polygonal window if(range.given) { owinInternalPoly(xrange, yrange, ..., poly=poly, unitname=unitname) } else { owinInternalPoly( ..., poly=poly, unitname=unitname) } } else { ## mask window if(range.given) { owinInternalMask(xrange, yrange, ..., mask=mask, xy=xy, unitname=unitname) } else { owinInternalMask( ..., mask=mask, xy=xy, unitname=unitname) } } } owinInternalRect <- function(xrange=c(0,1), yrange=c(0,1), ..., unitname=NULL, check = TRUE) { if(check) { if(!is.vector(xrange) || length(xrange) != 2 || xrange[2L] < xrange[1L]) stop("xrange should be a vector of length 2 giving (xmin, xmax)") if(!is.vector(yrange) || length(yrange) != 2 || yrange[2L] < yrange[1L]) stop("yrange should be a vector of length 2 giving (ymin, ymax)") } unitname <- as.unitname(unitname) w <- list(type="rectangle", xrange=xrange, yrange=yrange, units=unitname) class(w) <- "owin" return(w) } isXYdata <- function(x) { (is.matrix(x) || is.data.frame(x)) && ncol(x) == 2 } asXYdata <- function(xy) { list(x=xy[,1], y=xy[,2]) } owinInternalPoly <- function(xrange=c(0,1), yrange=c(0,1), ..., poly=NULL, unitname=NULL, check = TRUE, calculate = check, strict = spatstat.options("checkpolygons"), fix = spatstat.options("fixpolygons")) { unitname <- as.unitname(unitname) if(length(poly) == 0) { ## empty polygon if(check) { if(!is.vector(xrange) || length(xrange) != 2 || xrange[2L] < xrange[1L]) stop("xrange should be a vector of length 2 giving (xmin, xmax)") if(!is.vector(yrange) || length(yrange) != 2 || yrange[2L] < yrange[1L]) stop("yrange should be a vector of length 2 giving (ymin, ymax)") } w <- list(type="polygonal", xrange=xrange, yrange=yrange, bdry=list(), units=unitname) class(w) <- "owin" return(w) } ## convert matrix or data frame to list(x,y) if(isXYdata(poly)) { poly <- asXYdata(poly) } else if(is.list(poly) && all(unlist(lapply(poly, isXYdata)))) { poly <- lapply(poly, asXYdata) } ## nonempty polygon ## test whether it's a single polygon or multiple polygons if(verify.xypolygon(poly, fatal=FALSE)) psingle <- TRUE else if(all(unlist(lapply(poly, verify.xypolygon, fatal=FALSE)))) psingle <- FALSE else stop("poly must be either a list(x,y) or a list of list(x,y)") w.area <- NULL if(psingle) { ## single boundary polygon bdry <- unname(list(poly)) if(check || calculate) { w.area <- Area.xypolygon(poly) if(w.area < 0) stop(paste("Area of polygon is negative -", "maybe traversed in wrong direction?")) } } else { ## multiple boundary polygons bdry <- unname(poly) if(check || calculate) { w.area <- sapply(poly, Area.xypolygon) if(sum(w.area) < 0) stop(paste("Area of window is negative;\n", "check that all polygons were traversed", "in the right direction")) } } actual.xrange <- range(unlist(lapply(bdry, getElement, name="x"))) if(missing(xrange)) xrange <- actual.xrange else if(check) { if(!is.vector(xrange) || length(xrange) != 2 || xrange[2L] < xrange[1L]) stop("xrange should be a vector of length 2 giving (xmin, xmax)") if(!all(xrange == range(c(xrange, actual.xrange)))) stop("polygon's x coordinates outside xrange") } actual.yrange <- range(unlist(lapply(bdry, getElement, name="y"))) if(missing(yrange)) yrange <- actual.yrange else if(check) { if(!is.vector(yrange) || length(yrange) != 2 || yrange[2L] < yrange[1L]) stop("yrange should be a vector of length 2 giving (ymin, ymax)") if(!all(yrange == range(c(yrange, actual.yrange)))) stop("polygon's y coordinates outside yrange") } if(!is.null(w.area)) { ## tack on area and hole data holes <- (w.area < 0) for(i in seq_along(bdry)) bdry[[i]] <- append(bdry[[i]], list(area=w.area[i], hole=holes[i])) } w <- list(type="polygonal", xrange=xrange, yrange=yrange, bdry=bdry, units=unitname) class(w) <- "owin" if(check && strict) { ## strict checks on geometry (self-intersection etc) ok <- owinpolycheck(w) if(!ok) { errors <- attr(ok, "err") stop(paste("Polygon data contain", commasep(errors))) } } if(check && fix) { if(length(bdry) == 1 && length(bx <- bdry[[1L]]$x) == 4 && length(unique(bx)) == 2 && length(unique(bdry[[1L]]$y)) == 2) { ## it's really a rectangle if(Area.xypolygon(bdry[[1L]]) < 0) w$bdry <- lapply(bdry, reverse.xypolygon) } else { ## repair polygon data by invoking polyclip ## to intersect polygon with larger-than-bounding rectangle ## (Streamlined version of intersect.owin) ww <- lapply(bdry, reverse.xypolygon) xrplus <- mean(xrange) + c(-1,1) * diff(xrange) yrplus <- mean(yrange) + c(-1,1) * diff(yrange) bignum <- (.Machine$integer.max^2)/2 epsclip <- max(diff(xrange), diff(yrange))/bignum rr <- list(list(x=xrplus[c(1,2,2,1)], y=yrplus[c(2,2,1,1)])) bb <- polyclip::polyclip(ww, rr, "intersection", fillA="nonzero", fillB="nonzero", eps=epsclip) ## ensure correct polarity totarea <- sum(unlist(lapply(bb, Area.xypolygon))) if(totarea < 0) bb <- lapply(bb, reverse.xypolygon) w$bdry <- bb } } return(w) } owinInternalMask <- function(xrange=c(0,1), yrange=c(0,1), ..., mask=NULL, unitname=NULL, xy=NULL, check = TRUE) { unitname <- as.unitname(unitname) if(is.data.frame(mask) && ncol(mask) %in% c(2,3) && sum(sapply(mask, is.numeric)) == 2) { ## data frame with 2 columns of coordinates W <- as.owin(W=mask, xy=xy) unitname(W) <- unitname return(W) } if(!is.matrix(mask)) stop(paste(sQuote("mask"), "must be a matrix")) if(!is.logical(mask)) stop(paste("The entries of", sQuote("mask"), "must be logical")) if(anyNA(mask)) mask[is.na(mask)] <- FALSE nc <- ncol(mask) nr <- nrow(mask) if(!is.null(xy)) { ## pixel coordinates given explicitly ## validate dimensions if(!is.list(xy) || !checkfields(xy, c("x","y"))) stop("xy should be a list with entries x and y") xcol <- xy$x yrow <- xy$y if(length(xcol) != nc) stop(paste("length of xy$x =", length(xcol), "!=", nc, "= number of columns of mask")) if(length(yrow) != nr) stop(paste("length of xy$y =", length(yrow), "!=", nr, "= number of rows of mask")) ## x and y should be evenly spaced if(!evenly.spaced(xcol)) stop("xy$x is not evenly spaced") if(!evenly.spaced(yrow)) stop("xy$y is not evenly spaced") ## determine other parameters xstep <- diff(xcol)[1L] ystep <- diff(yrow)[1L] if(missing(xrange) && missing(yrange)) { xrange <- range(xcol) + c(-1,1) * xstep/2 yrange <- range(yrow) + c(-1,1) * ystep/2 } } else { ## determine pixel coordinates from xrange, yrange if(missing(xrange) && missing(yrange)) { ## take pixels to be 1 x 1 unit xrange <- c(0,nc) yrange <- c(0,nr) } else if(check) { if(!is.vector(xrange) || length(xrange) != 2 || xrange[2L] < xrange[1L]) stop("xrange should be a vector of length 2 giving (xmin, xmax)") if(!is.vector(yrange) || length(yrange) != 2 || yrange[2L] < yrange[1L]) stop("yrange should be a vector of length 2 giving (ymin, ymax)") } xstep <- diff(xrange)/nc ystep <- diff(yrange)/nr xcol <- seq(from=xrange[1L]+xstep/2, to=xrange[2L]-xstep/2, length.out=nc) yrow <- seq(from=yrange[1L]+ystep/2, to=yrange[2L]-ystep/2, length.out=nr) } out <- list(type = "mask", xrange = unname(xrange), yrange = unname(yrange), dim = c(nr, nc), xstep = unname(xstep), ystep = unname(ystep), warnings = .Spatstat.Image.Warning, xcol = unname(xcol), yrow = unname(yrow), m = mask, units = unitname) class(out) <- "owin" return(out) } # #----------------------------------------------------------------------------- # is.owin <- function(x) { inherits(x, "owin") } # #----------------------------------------------------------------------------- # as.owin <- function(W, ..., fatal=TRUE) { UseMethod("as.owin") } as.owin.owin <- function(W, ..., fatal=TRUE) { if(verifyclass(W, "owin", fatal=fatal)) return(owin(W$xrange, W$yrange, poly=W$bdry, mask=W$m, unitname=unitname(W), check=FALSE)) else return(NULL) } as.owin.ppp <- function(W, ..., fatal=TRUE) { if(verifyclass(W, "ppp", fatal=fatal)) return(W$window) else return(NULL) } as.owin.quad <- function(W, ..., fatal=TRUE) { if(verifyclass(W, "quad", fatal=fatal)) return(W$data$window) else return(NULL) } as.owin.im <- function(W, ..., fatal=TRUE) { if(!verifyclass(W, "im", fatal=fatal)) return(NULL) out <- list(type = "mask", xrange = W$xrange, yrange = W$yrange, dim = W$dim, xstep = W$xstep, ystep = W$ystep, warnings = .Spatstat.Image.Warning, xcol = W$xcol, yrow = W$yrow, m = !is.na(W$v), units = unitname(W)) class(out) <- "owin" return(out) } as.owin.psp <- function(W, ..., fatal=TRUE) { if(!verifyclass(W, "psp", fatal=fatal)) return(NULL) return(W$window) } as.owin.tess <- function(W, ..., fatal=TRUE) { if(!verifyclass(W, "tess", fatal=fatal)) return(NULL) return(W$window) } as.owin.data.frame <- function(W, ..., step, fatal=TRUE) { if(!verifyclass(W, "data.frame", fatal=fatal)) return(NULL) if(missing(step)) { xstep <- ystep <- NULL } else { step <- ensure2vector(step) xstep <- step[1L] ystep <- step[2L] } if(!(ncol(W) %in% c(2,3))) { whinge <- "need exactly 2 or 3 columns of data" if(fatal) stop(whinge) warning(whinge) return(NULL) } if(twocol <- (ncol(W) == 2)) { # assume data is a list of TRUE pixels W <- cbind(W, TRUE) } mch <- matchNameOrPosition(c("x", "y", "z"), names(W)) ix <- mch[1L] iy <- mch[2L] iz <- mch[3L] df <- data.frame(x=W[,ix], y=W[,iy], z=as.logical(W[,iz])) with(df, { xx <- sortunique(x) yy <- sortunique(y) jj <- match(x, xx) ii <- match(y, yy) ## make logical matrix (for incomplete x, y sequence) ok <- checkbigmatrix(length(xx), length(yy), fatal=fatal) if(!ok) return(NULL) mm <- matrix(FALSE, length(yy), length(xx)) mm[cbind(ii,jj)] <- z ## ensure xx and yy are complete equally-spaced sequences fx <- fillseq(xx, step=xstep) fy <- fillseq(yy, step=ystep) xcol <- fx[[1L]] yrow <- fy[[1L]] ## trap very large matrices ok <- checkbigmatrix(length(xcol), length(yrow), fatal=fatal) if(!ok) return(NULL) ## mapping from xx to xcol, yy to yrow jjj <- fx[[2L]] iii <- fy[[2L]] ## make logical matrix for full sequence m <- matrix(FALSE, length(yrow), length(xcol)) m[iii,jjj] <- mm ## make binary mask out <- owin(mask=m, xy=list(x=xcol, y=yrow)) ## warn if area fraction is small: may be a misuse of as.owin if(twocol) { pcarea <- 100 * nrow(df)/prod(dim(m)) if(pcarea < 1) warning(paste("Window occupies only", paste0(signif(pcarea, 2), "%"), "of frame area. Did you mean owin(poly=df) ?"), call.=FALSE) } return(out) }) } as.owin.default <- function(W, ..., fatal=TRUE) { ## Tries to interpret data as an object of class 'owin' ## W may be ## a structure with entries xrange, yrange ## a structure with entries xl, xu, yl, yu ## a structure with entries xmin, xmax, ymin, ymax ## a four-element vector (interpreted xmin, xmax, ymin, ymax) ## an object with attribute "bbox" if(inherits(W, "box3")) { #' cannot be flattened if(fatal) stop("3D box cannot be converted to a 2D window") return(NULL) } if(checkfields(W, c("xrange", "yrange"))) { Z <- owinInternalRect(W$xrange, W$yrange) return(Z) } else if(checkfields(W, c("xmin", "xmax", "ymin", "ymax"))) { W <- as.list(W) Z <- owinInternalRect(c(W$xmin, W$xmax),c(W$ymin, W$ymax)) return(Z) } else if(checkfields(W, c("xl", "xu", "yl", "yu"))) { W <- as.list(W) Z <- owinInternalRect(c(W$xl, W$xu),c(W$yl, W$yu)) return(Z) } else if(checkfields(W, c("x", "y", "area")) && checkfields(W$area, c("xl", "xu", "yl", "yu"))) { V <- as.list(W$area) Z <- owinInternalRect(c(V$xl, V$xu),c(V$yl, V$yu)) return(Z) } else if(is.vector(W) && is.numeric(W) && length(W) == 4) { Z <- owinInternalRect(W[1:2], W[3:4]) return(Z) } else if(!is.null(Z <- attr(W, "bbox"))) { return(as.owin(Z, ..., fatal=fatal)) } else if(inherits(W, c("SpatialPolygons", "SpatialPolygonsDataFrame"))) { gripe <- "The package 'maptools' is needed to convert this data type" if(fatal) stop(gripe, call.=FALSE) else warning(gripe, call.=FALSE) return(NULL) } else { #' no idea if(fatal) stop("Can't interpret W as a window", call.=FALSE) return(NULL) } } # #----------------------------------------------------------------------------- # # Frame <- function(X) { UseMethod("Frame") } "Frame<-" <- function(X, value) { UseMethod("Frame<-") } Frame.default <- function(X) { as.rectangle(X) } "Frame<-.default" <- function(X, value) { Frame(Window(X)) <- value return(X) } ## ......................................................... as.rectangle <- function(w, ...) { if(inherits(w, "owin")) return(owinInternalRect(w$xrange, w$yrange, unitname=unitname(w), check=FALSE)) if(inherits(w, "im")) return(owinInternalRect(w$xrange, w$yrange, unitname=unitname(w), check=FALSE)) if(inherits(w, "ppp")) return(owinInternalRect(w$window$xrange, w$window$yrange, unitname=unitname(w$window), check=FALSE)) if(inherits(w, "layered")) return(do.call(boundingbox, unname(lapply(w, as.rectangle, ...)))) w <- as.owin(w, ...) return(owinInternalRect(w$xrange, w$yrange, unitname=unitname(w), check=FALSE)) } ## ##---------------------------------------------------------------------------- ## AsMaskInternal <- function(w, ..., eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame")) { rule.eps <- match.arg(rule.eps) as.mask(w, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) } as.mask <- function(w, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame")) { ## eps: grid mesh (pixel) size ## dimyx: dimensions of pixel raster ## xy: coordinates of pixel raster ## rule.eps: rule for adjusting frame when 'eps' is given ########################### ## First determine window ########################### w.absent <- missing(w) || is.null(w) if(w.absent) { ## w is not given ## Ensure there is some window information if(is.null(xy)) stop("If w is missing, xy is required") uname <- unitname(xy) # could be null } else { ## w is given, but may require conversion ## Handle cases where w contains pixel data if(is.data.frame(w)) return(owin(mask=w, xy=xy)) if(is.matrix(w)) { w <- as.data.frame(w) colnames(w) <- c("x", "y") return(owin(mask=w, xy=xy)) } ## Handle cases where w can be converted to a window w <- as.owin(w) ## Already a mask? if(is.mask(w) && is.null(eps) && is.null(dimyx) && is.null(xy)) { ## w contained raster data, and no further raster data is provided return(w) } uname <- unitname(w) xrange <- w$xrange yrange <- w$yrange } ##################################### ## Next determine pixel coordinates ##################################### if(is.null(xy)) { ## Pixel coordinates to be computed from other dimensions ## First determine row & column dimensions if(!is.null(dimyx)) { ## Pixel dimensions are given dimyx <- ensure2vector(dimyx) nr <- dimyx[1L] nc <- dimyx[2L] } else { ## use pixel size 'eps' if(!is.null(eps)) { eps <- ensure2vector(eps) width <- diff(xrange) height <- diff(yrange) nc <- width/eps[1L] nr <- height/eps[2L] fc <- nc %% 1 fr <- nr %% 1 rule.eps <- match.arg(rule.eps) switch(rule.eps, adjust.eps = { ## Frame size is fixed; pixel size will be adjusted nc <- ceiling(nc) nr <- ceiling(nr) if(fc != 0) eps[1L] <- width/nc if(fr != 0) eps[2L] <- height/nr }, grow.frame = { ## Pixel size is fixed; frame will be expanded nc <- ceiling(nc) nr <- ceiling(nr) if(fc != 0) xrange <- mean(xrange) + c(-1,1) * nc * eps[1L]/2 if(fr != 0) yrange <- mean(yrange) + c(-1,1) * nr * eps[2L]/2 }, shrink.frame = { ## Pixel size is fixed; frame will be contracted nc <- floor(nc) nr <- floor(nr) if(nc <= 0 || nr <= 0) stop(paste("pixel size argument eps exceeds frame size;", "unable to shrink frame")) if(fc != 0) xrange <- mean(xrange) + c(-1,1) * nc * eps[1L]/2 if(fr != 0) yrange <- mean(yrange) + c(-1,1) * nr * eps[2L]/2 }) } else { ## use spatstat default dimensions np <- spatstat.options("npixel") if(length(np) == 1) nr <- nc <- np[1L] else { nr <- np[2L] nc <- np[1L] } } } if((mpix <- (nr * nc)/1048576) >= 10) { mpix <- round(mpix, 1) whinge <- paste("Creating", articlebeforenumber(mpix), paste0(mpix, "-megapixel"), "window mask") message(whinge) warning(whinge, call.=FALSE) } ## Initialise mask with all entries TRUE nowidth <- (diff(xrange) < .Machine$double.eps) noheight <- (diff(yrange) < .Machine$double.eps) if(nowidth || noheight) { if(nowidth && noheight) { nr <- nc <- 1 } else if(noheight) { nr <- 1 yrange <- yrange + c(-1/2,1/2) * diff(xrange)/(nc+1) } else if(nowidth) { ## ensure square pixels nc <- 1 xrange <- xrange + c(-1/2,1/2) * diff(yrange)/(nr+1) } } rasta <- owin(xrange, yrange, mask=matrix(TRUE, nr, nc)) } else { ## ## Pixel coordinates given explicitly: ## xy is an image, a mask, or a list(x,y) if(is.im(xy)) { rasta <- as.owin(xy) rasta$m[] <- TRUE } else if(is.owin(xy)) { if(xy$type != "mask") stop("argument xy does not contain raster coordinates.") rasta <- xy rasta$m[] <- TRUE } else { if(!checkfields(xy, c("x", "y"))) stop(paste(sQuote("xy"), "should be a list containing two vectors x and y")) x <- sortunique(xy$x) y <- sortunique(xy$y) ## derive other parameters nr <- length(y) nc <- length(x) ## check size if((mpix <- (nr * nc)/1048576) >= 10) { whinge <- paste("Creating", articlebeforenumber(mpix), paste0(round(mpix, 1), "-megapixel"), "window mask") message(whinge) warning(whinge, call.=FALSE) } ## x and y pixel sizes dx <- diff(x) if(diff(range(dx)) > 0.01 * mean(dx)) stop("x coordinates must be evenly spaced") xstep <- mean(dx) dy <- diff(y) if(diff(range(dy)) > 0.01 * mean(dy)) stop("y coordinates must be evenly spaced") ystep <- mean(dy) xr <- range(x) yr <- range(y) xrange <- xr + xstep * c(-1,1)/2 yrange <- yr + ystep * c(-1,1)/2 ## initialise mask with all entries TRUE rasta <- list(type = "mask", xrange = xrange, yrange = yrange, dim = c(nr, nc), xstep = xstep, ystep = ystep, warnings = .Spatstat.Image.Warning, xcol = seq(from=xr[1L], to=xr[2L], length.out=nc), yrow = seq(from=yr[1L], to=yr[2L], length.out=nr), m = matrix(TRUE, nr, nc), units = uname) class(rasta) <- "owin" } if(w.absent) { ## No more window information out <- rasta if(!(identical(x, xy$x) && identical(y, xy$y))) { ## xy is an enumeration of the TRUE pixels out$m[] <- FALSE ij <- cbind(i=match(xy$y, y), j=match(xy$x, x)) out$m[ij] <- TRUE } return(out) } } #################################################### ## Finally, mask pixel raster with existing window #################################################### switch(w$type, rectangle = { out <- rasta wxrange <- w$xrange wyrange <- w$yrange if(!all(wxrange == rasta$xrange) || !all(wyrange == rasta$yrange)) { xcol <- rasta$xcol yrow <- rasta$yrow badrow <- which(yrow > wyrange[2L] | yrow < wyrange[1L]) badcol <- which(xcol > wxrange[2L] | xcol < wxrange[1L]) out$m[badrow , ] <- FALSE out$m[ , badcol] <- FALSE } }, mask = { ## resample existing mask on new raster out <- rastersample(w, rasta) }, polygonal = { ## use C code out <- owinpoly2mask(w, rasta, FALSE) }) unitname(out) <- uname return(out) } as.matrix.owin <- function(x, ...) { m <- as.mask(x, ...) return(m$m) } # # #----------------------------------------------------------------------------- # as.polygonal <- function(W, repair=FALSE) { verifyclass(W, "owin") switch(W$type, rectangle = { xr <- W$xrange yr <- W$yrange return(owin(xr, yr, poly=list(x=xr[c(1,2,2,1)],y=yr[c(1,1,2,2)]), unitname=unitname(W), check=FALSE)) }, polygonal = { if(repair) W <- owin(poly=W$bdry, unitname=unitname(W)) return(W) }, mask = { # This could take a while M <- W$m nr <- nrow(M) notM <- !M xcol <- W$xcol yrow <- W$yrow ## determine resolution for polyclip operations eps <- max(W$xstep, W$ystep)/(2^31) eps <- max(eps, 4 * .Machine$double.eps) p <- list(x0 = xcol[1], y0 = yrow[1], eps = eps) ## pixels will be slightly expanded to avoid artefacts xbracket <- c(-1,1) * (W$xstep/2 + 4 * eps) ybracket <- c(-1,1) * (W$ystep/2 + 4 * eps) # identify runs of TRUE entries in each column start <- M & rbind(TRUE, notM[-nr, ]) finish <- M & rbind(notM[-1, ], TRUE) #' build result out <- NULL for(j in 1:ncol(M)) { xj <- xcol[j] # identify start and end positions in column j starts <- which(start[,j]) finishes <- which(finish[,j]) ns <- length(starts) nf <- length(finishes) if(ns != nf) stop(paste("Internal error: length(starts)=", ns, ", length(finishes)=", nf)) if(ns > 0) { for(k in 1:ns) { yfrom <- yrow[starts[k]] yto <- yrow[finishes[k]] yk <- sort(c(yfrom,yto)) #' make rectangle boundary in reversed orientation xrect <- xj + xbracket yrect <- yk + ybracket recto <- list(list(x = xrect[c(1,2,2,1)], y = yrect[c(2,2,1,1)])) #' add to result if(is.null(out)) { out <- recto } else { out <- polyclip::polyclip(out, recto, "union", fillA="nonzero", fillB="nonzero", eps = p$eps, x0 = p$x0, y0 = p$y0) } } } } if(is.null(out)) return(emptywindow(Frame(W))) totarea <- sum(sapply(out, Area.xypolygon)) if(totarea < 0) out <- lapply(out, reverse.xypolygon) out <- owin(poly=out, check=FALSE, unitname=unitname(W)) return(out) } ) } # # ---------------------------------------------------------------------- is.polygonal <- function(w) { return(inherits(w, "owin") && (w$type == "polygonal")) } is.rectangle <- function(w) { return(inherits(w, "owin") && (w$type == "rectangle")) } is.mask <- function(w) { return(inherits(w, "owin") && (w$type == "mask")) } validate.mask <- function(w, fatal=TRUE) { verifyclass(w, "owin", fatal=fatal) if(w$type == "mask") return(TRUE) if(fatal) stop(paste(short.deparse(substitute(w)), "is not a binary mask")) else { warning(paste(short.deparse(substitute(w)), "is not a binary mask")) return(FALSE) } } dim.owin <- function(x) { return(x$dim) } ## NULL unless it's a mask ## internal use only: rasterx.mask <- function(w, drop=FALSE) { validate.mask(w) x <- w$xcol[col(w)] x <- if(drop) x[w$m, drop=TRUE] else array(x, dim=w$dim) return(x) } rastery.mask <- function(w, drop=FALSE) { validate.mask(w) y <- w$yrow[row(w)] y <- if(drop) y[w$m, drop=TRUE] else array(y, dim=w$dim) return(y) } rasterxy.mask <- function(w, drop=FALSE) { validate.mask(w) x <- w$xcol[col(w)] y <- w$yrow[row(w)] if(drop) { m <- w$m x <- x[m, drop=TRUE] y <- y[m, drop=TRUE] } return(list(x=as.numeric(x), y=as.numeric(y))) } nearest.raster.point <- function(x,y,w, indices=TRUE) { stopifnot(is.mask(w) || is.im(w)) nr <- w$dim[1L] nc <- w$dim[2L] if(length(x) == 0) { cc <- rr <- integer(0) } else { cc <- 1 + round((x - w$xcol[1L])/w$xstep) rr <- 1 + round((y - w$yrow[1L])/w$ystep) cc <- pmax.int(1,pmin.int(cc, nc)) rr <- pmax.int(1,pmin.int(rr, nr)) } if(indices) return(list(row=rr, col=cc)) else return(list(x=w$xcol[cc], y=w$yrow[rr])) } mask2df <- function(w) { stopifnot(is.owin(w) && w$type == "mask") xx <- raster.x(w) yy <- raster.y(w) ok <- w$m xx <- as.vector(xx[ok]) yy <- as.vector(yy[ok]) return(data.frame(x=xx, y=yy)) } #------------------------------------------------------------------ complement.owin <- function(w, frame=as.rectangle(w)) { w <- as.owin(w) if(reframe <- !missing(frame)) { verifyclass(frame, "owin") w <- rebound.owin(w, frame) # if w was a rectangle, it's now polygonal } switch(w$type, mask = { w$m <- !(w$m) }, rectangle = { # return empty window return(emptywindow(w)) }, polygonal = { bdry <- w$bdry if(length(bdry) == 0) { # w is empty return(frame) } # bounding box, in anticlockwise order box <- list(x=w$xrange[c(1,2,2,1)], y=w$yrange[c(1,1,2,2)]) boxarea <- Area.xypolygon(box) # first check whether one of the current boundary polygons # is the bounding box itself (with + sign) if(reframe) is.box <- rep.int(FALSE, length(bdry)) else { nvert <- lengths(lapply(bdry, getElement, name="x")) areas <- sapply(bdry, Area.xypolygon) boxarea.mineps <- boxarea * (0.99999) is.box <- (nvert == 4 & areas >= boxarea.mineps) if(sum(is.box) > 1) stop("Internal error: multiple copies of bounding box") if(all(is.box)) { return(emptywindow(box)) } } # if box is present (with + sign), remove it if(any(is.box)) bdry <- bdry[!is.box] # now reverse the direction of each polygon bdry <- lapply(bdry, reverse.xypolygon, adjust=TRUE) # if box was absent, add it if(!any(is.box)) bdry <- c(bdry, list(box)) # sic # put back into w w$bdry <- bdry }, stop("unrecognised window type", w$type) ) return(w) } #----------------------------------------------------------- inside.owin <- function(x, y, w) { # test whether (x,y) is inside window w # x, y may be vectors if((missing(y) || is.null(y)) && all(c("x", "y") %in% names(x))) { y <- x$y x <- x$x } w <- as.owin(w) if(length(x)==0) return(logical(0)) # test whether inside bounding rectangle xr <- w$xrange yr <- w$yrange eps <- sqrt(.Machine$double.eps) frameok <- (x >= xr[1L] - eps) & (x <= xr[2L] + eps) & (y >= yr[1L] - eps) & (y <= yr[2L] + eps) if(!any(frameok)) # all points OUTSIDE window - no further work needed return(frameok) ok <- frameok switch(w$type, rectangle = { return(ok) }, polygonal = { ## check scale framesize <- max(diff(xr), diff(yr)) if(framesize > 1e6 || framesize < 1e-6) { ## rescale to avoid numerical overflow scalefac <- as.numeric(framesize)/100 w <- as.polygonal(rescale(w, scalefac)) x <- x/scalefac y <- y/scalefac } xy <- list(x=x,y=y) bdry <- w$bdry total <- numeric(length(x)) on.bdry <- rep.int(FALSE, length(x)) for(i in seq_along(bdry)) { score <- inside.xypolygon(xy, bdry[[i]], test01=FALSE) total <- total + score on.bdry <- on.bdry | attr(score, "on.boundary") } # any points identified as belonging to the boundary get score 1 total[on.bdry] <- 1 # check for sanity now.. uhoh <- (total * (1-total) != 0) if(any(uhoh)) { nuh <- sum(uhoh) warning(paste("point-in-polygon test had difficulty with", nuh, ngettext(nuh, "point", "points"), "(total score not 0 or 1)"), call.=FALSE) total[uhoh] <- 0 } return(ok & (total != 0)) }, mask = { # consider only those points which are inside the frame xf <- x[frameok] yf <- y[frameok] # map locations to raster (row,col) coordinates loc <- nearest.raster.point(xf,yf,w) # look up mask values okf <- (w$m)[cbind(loc$row, loc$col)] # insert into 'ok' vector ok[frameok] <- okf return(ok) }, stop("unrecognised window type", w$type) ) } #------------------------------------------------------------------------- print.owin <- function(x, ..., prefix="window: ") { verifyclass(x, "owin") unitinfo <- summary(unitname(x)) switch(x$type, rectangle={ rectname <- paste0(prefix, "rectangle =") }, polygonal={ nonemp <- (length(x$bdry) != 0) splat(paste0(prefix, if(nonemp) "polygonal boundary" else "empty")) rectname <- "enclosing rectangle:" }, mask={ splat(paste0(prefix, "binary image mask")) di <- x$dim splat(di[1L], "x", di[2L], "pixel array (ny, nx)") rectname <- "enclosing rectangle:" } ) splat(rectname, prange(zapsmall(x$xrange)), "x", prange(zapsmall(x$yrange)), unitinfo$plural, unitinfo$explain) invisible(NULL) } summary.owin <- function(object, ...) { verifyclass(object, "owin") result <- list(xrange=object$xrange, yrange=object$yrange, type=object$type, area=area(object), units=unitname(object)) result$areafraction <- with(result, area/(diff(xrange) * diff(yrange))) switch(object$type, rectangle={ }, polygonal={ poly <- object$bdry result$npoly <- npoly <- length(poly) if(npoly == 0) { result$areas <- result$nvertices <- numeric(0) } else if(npoly == 1) { result$areas <- Area.xypolygon(poly[[1L]]) result$nvertices <- length(poly[[1L]]$x) } else { result$areas <- unlist(lapply(poly, Area.xypolygon)) result$nvertices <- lengths(lapply(poly, getElement, name="x")) } result$nhole <- sum(result$areas < 0) }, mask={ result$npixels <- object$dim result$xstep <- object$xstep result$ystep <- object$ystep } ) class(result) <- "summary.owin" result } print.summary.owin <- function(x, ...) { verifyclass(x, "summary.owin") unitinfo <- summary(x$units) pluralunits <- unitinfo$plural singularunits <- unitinfo$singular switch(x$type, rectangle={ rectname <- "Window: rectangle =" }, polygonal={ np <- x$npoly splat("Window: polygonal boundary") if(np == 0) { splat("window is empty") } else if(np == 1) { splat("single connected closed polygon with", x$nvertices, "vertices") } else { nh <- x$nhole holy <- if(nh == 0) "(no holes)" else if(nh == 1) "(1 hole)" else paren(paste(nh, "holes")) splat(np, "separate polygons", holy) if(np > 0) print(data.frame(vertices=x$nvertices, area=signif(x$areas, 6), relative.area=signif(x$areas/x$area,3), row.names=paste("polygon", 1:np, ifelse(x$areas < 0, "(hole)", "") ))) } rectname <- "enclosing rectangle:" }, mask={ splat("binary image mask") di <- x$npixels splat(di[1L], "x", di[2L], "pixel array (ny, nx)") splat("pixel size:", signif(x$xstep,3), "by", signif(x$ystep,3), pluralunits) rectname <- "enclosing rectangle:" } ) splat(rectname, prange(zapsmall(x$xrange)), "x", prange(zapsmall(x$yrange)), pluralunits) if(x$xrange[1] != 0 || x$yrange[1] != 0) { width <- diff(x$xrange) height <- diff(x$yrange) blank <- paste(rep(" ", nchar(rectname)), collapse="") splat(blank, paren(paste(signif(width, 4), "x", signif(height, 4), pluralunits))) } Area <- signif(x$area, 6) splat("Window area =", Area, "square", if(Area == 1) singularunits else pluralunits) if(!is.null(ledge <- unitinfo$legend)) splat(ledge) if(x$type != "rectangle") splat("Fraction of frame area:", signif(x$areafraction, 3)) return(invisible(x)) } as.data.frame.owin <- function(x, ..., drop=TRUE) { stopifnot(is.owin(x)) switch(x$type, rectangle = { x <- as.polygonal(x) }, polygonal = { }, mask = { xy <- rasterxy.mask(x, drop=drop) if(!drop) xy <- append(xy, list(inside=as.vector(x$m))) return(as.data.frame(xy, ...)) }) b <- x$bdry ishole <- sapply(b, is.hole.xypolygon) sign <- (-1)^ishole b <- lapply(b, as.data.frame, ...) nb <- length(b) if(nb == 1) return(b[[1L]]) dfs <- mapply(cbind, b, id=as.list(seq_len(nb)), sign=as.list(sign), SIMPLIFY=FALSE) df <- do.call(rbind, dfs) return(df) } discretise <- function(X, eps=NULL, dimyx=NULL, xy=NULL, move.points=FALSE, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame")) { verifyclass(X,"ppp") W <- X$window ok <- inside.owin(X$x,X$y,W) if(!all(ok)) stop("There are points of X outside the window of X") new.grid <- !is.null(eps) || !is.null(dimyx) || !is.null(xy) if(new.grid) rule.eps <- match.arg(rule.eps) new.mask <- new.grid || !is.mask(W) WM <- if(!new.mask) W else as.mask(W, eps=eps,dimyx=dimyx,xy=xy,rule.eps=rule.eps) if(move.points) { ## move points to pixel centres if(new.mask) X$window <- WM indices <- as.data.frame(nearest.valid.pixel(X$x, X$y, WM, nsearch=2)) xnew <- WM$xcol[indices$col] ynew <- WM$yrow[indices$row] ## insurance: if(any(notfound <- !complete.cases(indices))) { XP <- project2set(X[notfound], WM) xnew[notfound] <- XP$x ynew[notfound] <- XP$y } X$x <- xnew X$y <- ynew } else if(new.mask) { ## ensure points are inside new window nok <- !inside.owin(X$x,X$y,WM) if(any(nok)) { ifix <- nearest.raster.point(X$x[nok],X$y[nok], WM) ifix <- cbind(ifix$row,ifix$col) WM$m[ifix] <- TRUE } X$window <- WM } return(X) } pixelcentres <- function (X, W=NULL,...) { X <- as.mask(as.owin(X), ...) if(is.null(W)) W <- as.rectangle(X) Y <- as.ppp(raster.xy(X,drop=TRUE),W=W) return(Y) } owin2polypath <- function(w) { w <- as.polygonal(w) b <- w$bdry xvectors <- lapply(b, getElement, name="x") yvectors <- lapply(b, getElement, name="y") xx <- unlist(lapply(xvectors, append, values=NA, after=FALSE))[-1] yy <- unlist(lapply(yvectors, append, values=NA, after=FALSE))[-1] return(list(x=xx, y=yy)) } ## generics which extract and assign the window of some object Window <- function(X, ...) { UseMethod("Window") } "Window<-" <- function(X, ..., value) { UseMethod("Window<-") } spatstat.geom/R/replace.ppp.R0000644000176200001440000000354414611065352015611 0ustar liggesusers# # replace.ppp.R # "[<-.ppp" <- function(x, i, j, value) { verifyclass(x, "ppp") verifyclass(value, "ppp") if(missing(i) && missing(j)) return(value) if(missing(i)) { message("The use of argument j in [<-.ppp is deprecated; use argument i") # invoke code below x[j] <- value return(x) } xmf <- markformat(x) vmf <- markformat(value) if(xmf != vmf) { if(xmf == "none") stop("Replacement points are marked, but x is not marked") else if(vmf == "none") stop("Replacement points have no marks, but x is marked") else stop("Format of marks in replacement is incompatible with original") } if(inherits(i, "owin")) { win <- i vok <- inside.owin(value$x, value$y, win) if(!all(vok)) { warning("Replacement points outside the specified window were deleted") value <- value[vok] } # convert to vector index i <- inside.owin(x$x, x$y, win) } if(!is.vector(i)) stop("Unrecognised format for subset index i") # vector index # determine index subset n <- x$n SUB <- seq_len(n)[i] # anything to replace? if(length(SUB) == 0) return(x) # sanity checks if(anyNA(SUB)) stop("Invalid subset: the resulting subscripts include NAs") # exact replacement of this subset? if(value$n == length(SUB)) { x$x[SUB] <- value$x x$y[SUB] <- value$y switch(xmf, none={}, list=, vector={ x$marks[SUB] <- value$marks }, dataframe={ x$marks[SUB,] <- value$marks }) } else x <- superimpose(x[-SUB], value, W=x$window) if(!missing(j)) { warning("The use of argument j in [<-.ppp is deprecated; use argument i") # invoke code above x[j] <- value } return(x) } spatstat.geom/R/colourtables.R0000644000176200001440000005525714723211063016102 0ustar liggesusers# # colourtables.R # # support for colour maps and other lookup tables # # $Revision: 1.63 $ $Date: 2024/12/02 01:41:18 $ # colourmap <- function(col, ..., range=NULL, breaks=NULL, inputs=NULL, gamma=1) { if(nargs() == 0) { ## null colour map f <- lut() } else { ## validate colour data col2hex(col) ## store without conversion f <- lut(col, ..., range=range, breaks=breaks, inputs=inputs, gamma=gamma) } class(f) <- c("colourmap", class(f)) f } lut <- function(outputs, ..., range=NULL, breaks=NULL, inputs=NULL, gamma=1) { if(nargs() == 0) { ## null lookup table f <- function(x, what="value"){NULL} class(f) <- c("lut", class(f)) attr(f, "stuff") <- list(n=0) return(f) } if(is.null(gamma)) gamma <- 1 n <- length(outputs) given <- c(!is.null(range), !is.null(breaks), !is.null(inputs)) names(given) <- nama <- c("range", "breaks", "inputs") ngiven <- sum(given) if(ngiven == 0L) stop(paste("One of the arguments", commasep(sQuote(nama), "or"), "should be given")) if(ngiven > 1L) { offending <- nama[given] stop(paste("The arguments", commasep(sQuote(offending)), "are incompatible")) } if(!is.null(inputs)) { #' discrete set of input values mapped to output values if(n == 1L) { #' constant output n <- length(inputs) outputs <- rep(outputs, n) } else stopifnot(length(inputs) == length(outputs)) stuff <- list(n=n, discrete=TRUE, inputs=inputs, outputs=outputs) f <- function(x, what="value") { m <- match(x, stuff$inputs) if(what == "index") return(m) cout <- stuff$outputs[m] return(cout) } } else { #' range of numbers, or date/time interval, mapped to colours #' determine type of domain timeclasses <- c("Date", "POSIXt") is.time <- inherits(range, timeclasses) || inherits(breaks, timeclasses) #' determine breaks if(is.null(breaks)) { breaks <- gammabreaks(range, n + 1L, gamma) gamma.used <- gamma } else { stopifnot(length(breaks) >= 2) if(length(outputs) == 1L) { n <- length(breaks) - 1L outputs <- rep(outputs, n) } else stopifnot(length(breaks) == length(outputs) + 1L) if(!all(diff(breaks) > 0)) stop("breaks must be increasing") gamma.used <- NULL } stuff <- list(n=n, discrete=FALSE, breaks=breaks, outputs=outputs, gamma=gamma.used) #' use appropriate function if(is.time) { f <- function(x, what="value") { x <- as.vector(as.numeric(x)) z <- findInterval(x, stuff$breaks, rightmost.closed=TRUE) oo <- stuff$outputs z[z <= 0 | z > length(oo)] <- NA if(what == "index") return(z) cout <- oo[z] return(cout) } } else { f <- function(x, what="value") { stopifnot(is.numeric(x)) x <- as.vector(x) z <- findInterval(x, stuff$breaks, rightmost.closed=TRUE) oo <- stuff$outputs z[z <= 0 | z > length(oo)] <- NA if(what == "index") return(z) cout <- stuff$outputs[z] return(cout) } } } attr(f, "stuff") <- stuff class(f) <- c("lut", class(f)) f } print.lut <- function(x, ...) { if(inherits(x, "colourmap")) { tablename <- "Colour map" outputname <- "colour" } else { tablename <- "Lookup table" outputname <- "output" } stuff <- attr(x, "stuff") n <- stuff$n if(n == 0) { ## Null map cat(paste("Null", tablename, "\n")) return(invisible(NULL)) } if(stuff$discrete) { cat(paste(tablename, "for discrete set of input values\n")) out <- data.frame(input=stuff$inputs, output=stuff$outputs) } else { b <- stuff$breaks cat(paste(tablename, "for the range", prange(b[c(1L,n+1L)]), "\n")) leftend <- rep("[", n) rightend <- c(rep(")", n-1), "]") inames <- paste(leftend, b[-(n+1L)], ", ", b[-1L], rightend, sep="") out <- data.frame(interval=inames, output=stuff$outputs) } colnames(out)[2L] <- outputname print(out) if(!is.null(gamma <- stuff$gamma) && gamma != 1) cat(paste("Generated using gamma =", gamma, "\n")) invisible(NULL) } print.colourmap <- function(x, ...) { NextMethod("print") } summary.lut <- function(object, ...) { s <- attr(object, "stuff") if(inherits(object, "colourmap")) { s$tablename <- "Colour map" s$outputname <- "colour" } else { s$tablename <- "Lookup table" s$outputname <- "output" } class(s) <- "summary.lut" return(s) } print.summary.lut <- function(x, ...) { n <- x$n if(n == 0) { cat(paste("Null", x$tablename, "\n")) return(invisible(NULL)) } if(x$discrete) { cat(paste(x$tablename, "for discrete set of input values\n")) out <- data.frame(input=x$inputs, output=x$outputs) } else { b <- x$breaks cat(paste(x$tablename, "for the range", prange(b[c(1L,n+1L)]), "\n")) leftend <- rep("[", n) rightend <- c(rep(")", n-1L), "]") inames <- paste(leftend, b[-(n+1L)], ", ", b[-1L], rightend, sep="") out <- data.frame(interval=inames, output=x$outputs) } colnames(out)[2L] <- x$outputname print(out) } plot.colourmap <- local({ # recognised additional arguments to image.default() and axis() imageparams <- c("main", "asp", "sub", "axes", "ann", "cex", "font", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col.axis", "col.lab", "col.main", "col.sub", "font.axis", "font.lab", "font.main", "font.sub") axisparams <- c("cex", "cex.axis", "cex.lab", "col.axis", "col.lab", "font.axis", "font.lab", "las", "mgp", "xaxp", "yaxp", "tck", "tcl", "xpd") linmap <- function(x, from, to) { dFrom <- as.numeric(diff(from)) dTo <- as.numeric(diff(to)) b <- dTo/dFrom if(is.nan(b)) b <- 0 if(!is.finite(b)) stop("Internal error: Cannot map zero width interval") to[1L] + b * (x - from[1L]) } ensurenumeric <- function(x) { if(is.numeric(x)) x else as.numeric(x) } # rules to determine the ribbon dimensions when one dimension is given widthrule <- function(heightrange, separate, n, gap) { dh <- diff(heightrange) if(separate || dh == 0) 1 else dh/10 } heightrule <- function(widthrange, separate, n, gap) { dw <- diff(widthrange) if(dw == 0) 1 else (dw * (if(separate) (n + (n-1)*gap) else 10)) } sideCode <- function(side) { if(is.numeric(side)) { stopifnot(side %in% 1:4) sidecode <- side } else if(is.character(side)) { nama <- c("bottom", "left", "top", "right") side <- match.arg(side, nama) sidecode <- match(side, nama) } else stop("Unrecognised format for 'side'") return(sidecode) } Ticks <- function(usr, log=FALSE, nint=NULL, ..., clip=TRUE) { #' modification of grDevices::axisTicks #' constrains ticks to be inside the specified range 'usr' if clip=TRUE #' accepts nint=NULL as if it were missing z <- if(is.null(nint)) axisTicks(usr=usr, log=log, ...) else axisTicks(usr=usr, log=log, nint=nint, ...) if(clip) { zlimits <- if(log) 10^usr else usr z <- z[inside.range(z, zlimits)] } return(z) } plot.colourmap <- function(x, ..., main, xlim=NULL, ylim=NULL, vertical=FALSE, axis=TRUE, side = if(vertical) "right" else "bottom", labelmap=NULL, gap=0.25, add=FALSE, increasing=NULL, nticks=5, box=NULL) { if(missing(main)) main <- short.deparse(substitute(x)) if(missing(vertical) && !missing(side)) vertical <- (sideCode(side) %in% c(2, 4)) dotargs <- list(...) if(inherits(dotargs$col, "colourmap")) dotargs <- dotargs[names(dotargs) != "col"] stuff <- attr(x, "stuff") col <- stuff$outputs n <- stuff$n if(n == 0) { ## Null map return(invisible(NULL)) } discrete <- stuff$discrete if(discrete) { check.1.real(gap, "In plot.colourmap") explain.ifnot(gap >= 0, "In plot.colourmap") } separate <- discrete && (gap > 0) if(is.null(labelmap)) { labelmap <- function(x) x } else if(is.numeric(labelmap) && length(labelmap) == 1L && !discrete) { labscal <- labelmap labelmap <- function(x) { x * labscal } } else stopifnot(is.function(labelmap)) if(is.null(increasing)) increasing <- !(discrete && vertical) reverse <- !increasing #' determine pixel entries 'v' and colour map breakpoints 'bks' #' to be passed to 'image.default' trivial <- FALSE if(!discrete) { # real numbers: continuous ribbon bks <- stuff$breaks rr <- range(bks) trivial <- (diff(rr) == 0) v <- if(trivial) rr[1] else seq(from=rr[1L], to=rr[2L], length.out=max(n+1L, 1024)) } else if(!separate) { # discrete values: blocks of colour, run together v <- (1:n) - 0.5 bks <- 0:n rr <- c(0,n) } else { # discrete values: separate blocks of colour vleft <- (1+gap) * (0:(n-1L)) vright <- vleft + 1 v <- vleft + 0.5 rr <- c(0, n + (n-1)*gap) } # determine position of ribbon or blocks of colour if(is.null(xlim) && is.null(ylim)) { u <- widthrule(rr, separate, n, gap) if(!vertical) { xlim <- rr ylim <- c(0,u) } else { xlim <- c(0,u) ylim <- rr } } else if(is.null(ylim)) { if(!vertical) ylim <- c(0, widthrule(xlim, separate, n, gap)) else ylim <- c(0, heightrule(xlim, separate, n, gap)) } else if(is.null(xlim)) { if(!vertical) xlim <- c(0, heightrule(ylim, separate, n, gap)) else xlim <- c(0, widthrule(ylim, separate, n, gap)) } # .......... initialise plot ............................... if(!add) do.call.matched(plot.default, resolve.defaults(list(x=xlim, y=ylim, type="n", main=main, axes=FALSE, xlab="", ylab="", asp=1.0), dotargs)) if(separate) { # ................ plot separate blocks of colour ................. if(reverse) col <- rev(col) if(!vertical) { # horizontal arrangement of blocks xleft <- linmap(vleft, rr, xlim) xright <- linmap(vright, rr, xlim) y <- ylim z <- matrix(1, 1L, 1L) for(i in 1:n) { x <- c(xleft[i], xright[i]) do.call.matched(image.default, resolve.defaults(list(x=ensurenumeric(x), y=ensurenumeric(y), z=z, add=TRUE, col=col[i]), dotargs), extrargs=imageparams) } } else { # vertical arrangement of blocks x <- xlim ylow <- linmap(vleft, rr, ylim) yupp <- linmap(vright, rr, ylim) z <- matrix(1, 1L, 1L) for(i in 1:n) { y <- c(ylow[i], yupp[i]) do.call.matched(image.default, resolve.defaults(list(x=ensurenumeric(x), y=ensurenumeric(y), z=z, add=TRUE, col=col[i]), dotargs), extrargs=imageparams) } } } else { # ................... plot ribbon image ............................. if(!vertical) { # horizontal colour ribbon x <- linmap(v, rr, xlim) y <- ylim z <- matrix(v, ncol=1L) } else { # vertical colour ribbon y <- linmap(v, rr, ylim) z <- matrix(v, nrow=1L) x <- xlim } #' deal with Date or integer values x <- ensurenumeric(x) if(!trivial) { if(any(diff(x) == 0)) x <- seq(from=x[1L], to=x[length(x)], length.out=length(x)) y <- ensurenumeric(y) if(any(diff(y) == 0)) y <- seq(from=y[1L], to=y[length(y)], length.out=length(y)) bks <- ensurenumeric(bks) if(any(diff(bks) <= 0)) { ok <- (diff(bks) > 0) bks <- bks[ok] col <- col[ok] } } if(reverse) col <- rev(col) do.call.matched(image.default, resolve.defaults(list(x=x, y=y, z=z, add=TRUE, breaks=ensurenumeric(bks), col=col), dotargs), extrargs=imageparams) } #' draw box around colours? #' default is TRUE unless drawing blocks of colour with gaps between. if(is.null(box)) box <- !separate if(!isFALSE(box)) rect(xlim[1], ylim[1], xlim[2], ylim[2]) if(axis) { # ................. draw annotation .................. if(!vertical) { # add horizontal axis/annotation if(discrete) { la <- paste(labelmap(stuff$inputs)) at <- linmap(v, rr, xlim) } else { la <- Ticks(rr, nint=nticks) at <- linmap(la, rr, xlim) la <- labelmap(la) } if(reverse) at <- rev(at) # default axis position is below the ribbon (side=1) sidecode <- sideCode(side) if(!(sidecode %in% c(1L,3L))) warning(paste("side =", if(is.character(side)) sQuote(side) else side, "is not consistent with horizontal orientation")) pos <- c(ylim[1L], xlim[1L], ylim[2L], xlim[2L])[sidecode] # don't draw axis lines if plotting separate blocks lwd0 <- if(separate) 0 else 1 # draw axis do.call.matched(graphics::axis, resolve.defaults(dotargs, list(side = sidecode, pos = pos, at = ensurenumeric(at), labels=la, lwd=lwd0)), extrargs=axisparams) } else { # add vertical axis if(discrete) { la <- paste(labelmap(stuff$inputs)) at <- linmap(v, rr, ylim) } else { la <- Ticks(rr, nint=nticks) at <- linmap(la, rr, ylim) la <- labelmap(la) } if(reverse) at <- rev(at) # default axis position is to the right of ribbon (side=4) sidecode <- sideCode(side) if(!(sidecode %in% c(2L,4L))) warning(paste("side =", if(is.character(side)) sQuote(side) else side, "is not consistent with vertical orientation")) pos <- c(ylim[1L], xlim[1L], ylim[2L], xlim[2L])[sidecode] # don't draw axis lines if plotting separate blocks lwd0 <- if(separate) 0 else 1 # draw labels horizontally if plotting separate blocks las0 <- if(separate) 1 else 0 # draw axis do.call.matched(graphics::axis, resolve.defaults(dotargs, list(side=sidecode, pos=pos, at=ensurenumeric(at), labels=la, lwd=lwd0, las=las0)), extrargs=axisparams) } } invisible(NULL) } plot.colourmap }) # Interpolate a colourmap or lookup table defined on real numbers interp.colourmap <- function(m, n=512) { if(!inherits(m, "colourmap")) stop("m should be a colourmap") st <- attr(m, "stuff") if(st$discrete) { # discrete set of input values mapped to colours xknots <- st$inputs # Ensure the inputs are real numbers if(!is.numeric(xknots)) stop("Cannot interpolate: inputs are not numerical values") } else { # interval of real line, chopped into intervals, mapped to colours # Find midpoints of intervals bks <- st$breaks nb <- length(bks) xknots <- (bks[-1L] + bks[-nb])/2 } # corresponding colours in hsv coordinates yknots.hsv <- rgb2hsva(col2rgb(st$outputs, alpha=TRUE)) # transform 'hue' from polar to cartesian coordinate # divide domain into n equal intervals xrange <- range(xknots) xbreaks <- seq(xrange[1L], xrange[2L], length=n+1L) xx <- (xbreaks[-1L] + xbreaks[-(n+1L)])/2 # interpolate saturation and value in hsv coordinates yy.sat <- approx(x=xknots, y=yknots.hsv["s", ], xout=xx)$y yy.val <- approx(x=xknots, y=yknots.hsv["v", ], xout=xx)$y # interpolate hue by first transforming polar to cartesian coordinate yknots.hue <- 2 * pi * yknots.hsv["h", ] yy.huex <- approx(x=xknots, y=cos(yknots.hue), xout=xx)$y yy.huey <- approx(x=xknots, y=sin(yknots.hue), xout=xx)$y yy.hue <- (atan2(yy.huey, yy.huex)/(2 * pi)) %% 1 # handle transparency yknots.alpha <- yknots.hsv["alpha", ] if(all(yknots.alpha == 1)) { ## opaque colours: form using hue, sat, val yy <- hsv(yy.hue, yy.sat, yy.val) } else { ## transparent colours: interpolate alpha yy.alpha <- approx(x=xknots, y=yknots.alpha, xout=xx)$y ## form colours using hue, sat, val, alpha yy <- hsv(yy.hue, yy.sat, yy.val, yy.alpha) } # done f <- colourmap(yy, breaks=xbreaks) return(f) } interp.colours <- function(x, length.out=512) { y <- colourmap(x, range=c(0,1)) z <- interp.colourmap(y, length.out) oo <- attr(z, "stuff")$outputs return(oo) } tweak.colourmap <- local({ is.hex <- function(z) { is.character(z) && all(nchar(z, keepNA=TRUE) %in% c(7L,9L)) && identical(substr(z, 1L, 7L), substr(col2hex(z), 1L, 7L)) } tweak.colourmap <- function(m, col, ..., inputs=NULL, range=NULL) { if(!inherits(m, "colourmap")) stop("m should be a colourmap") if(is.null(inputs) && is.null(range)) stop("Specify either inputs or range") if(!is.null(inputs) && !is.null(range)) stop("Do not specify both inputs and range") ## determine indices of colours to be changed if(!is.null(inputs)) { ix <- m(inputs, what="index") } else { if(!(is.numeric(range) && length(range) == 2 && diff(range) > 0)) stop("range should be a numeric vector of length 2 giving (min, max)") if(length(col2hex(col)) != 1L) stop("When range is given, col should be a single colour value") ixr <- m(range, what="index") ix <- (ixr[1L]):(ixr[2L]) } ## reassign colours st <- attr(m, "stuff") outputs <- st$outputs result.hex <- FALSE if(is.hex(outputs)) { ## convert replacement data to hex col <- col2hex(col) result.hex <- TRUE } else if(is.hex(col)) { ## convert existing data to hex outputs <- col2hex(outputs) result.hex <- TRUE } else if(!(is.character(outputs) && is.character(col))) { ## unrecognised format - convert both to hex outputs <- col2hex(outputs) col <- col2hex(col) result.hex <- TRUE } if(result.hex) { ## hex codes may be 7 or 9 characters outlen <- nchar(outputs) collen <- nchar(col) if(length(unique(c(outlen, collen))) > 1L) { ## convert all to 9 characters if(any(bad <- (outlen == 7))) outputs[bad] <- paste0(outputs[bad], "FF") if(any(bad <- (collen == 7))) col[bad] <- paste0(col[bad], "FF") } } ## Finally, replace outputs[ix] <- col st$outputs <- outputs attr(m, "stuff") <- st assign("stuff", st, envir=environment(m)) return(m) } tweak.colourmap }) colouroutputs <- function(x) { stopifnot(inherits(x, "colourmap")) attr(x, "stuff")$outputs } "colouroutputs<-" <- function(x, value) { stopifnot(inherits(x, "colourmap")) st <- attr(x, "stuff") col2hex(value) # validates colours st$outputs[] <- value attr(x, "stuff") <- st assign("stuff", st, envir=environment(x)) return(x) } rev.colourmap <- function(x) { colouroutputs(x) <- rev(colouroutputs(x)) return(x) } restrict.colourmap <- function(x, ..., range=NULL, breaks=NULL, inputs=NULL) { stopifnot(inherits(x, "colourmap")) given <- c(!is.null(range), !is.null(breaks), !is.null(inputs)) names(given) <- nama <- c("range", "breaks", "inputs") ngiven <- sum(given) if(ngiven == 0L) return(x) if(ngiven > 1L) { offending <- nama[given] stop(paste("The arguments", commasep(sQuote(offending)), "are incompatible")) } stuff <- attr(x, "stuff") if(!is.null(inputs)) { ## discrete colour map if(!stuff$discrete) stop("Cannot update 'inputs'; the existing colour map is not discrete", call.=FALSE) oldinputs <- stuff$inputs oldoutputs <- stuff$outputs m <- match(inputs, oldinputs) if(any(is.na(m))) stop("New inputs are not a subset of the old inputs", call.=FALSE) result <- colourmap(oldoutputs[m], inputs=inputs) } else if(!is.null(range)) { ## colour map for continuous domain ## range specified if(stuff$discrete) stop("Cannot update 'range'; the existing colour map is discrete", call.=FALSE) check.range(range) oldbreaks <- stuff$breaks if(!all(inside.range(range, range(oldbreaks)))) stop("new range of values is not a subset of current range") ## restrict existing breaks to new range newbreaks <- pmax(range[1], pmin(range[2], oldbreaks)) newbreaks <- unique(newbreaks) ## evaluate current colour at midpoint of each new interval newmid <- newbreaks[-length(newbreaks)] + diff(newbreaks)/2 newout <- x(newmid) result <- colourmap(newout, breaks=newbreaks) } else { ## colour map for continuous domain ## breaks specified if(stuff$discrete) stop("Cannot update 'breaks'; the existing colour map is discrete", call.=FALSE) oldbreaks <- stuff$breaks if(!all(inside.range(breaks, range(oldbreaks)))) stop("new range of 'breaks' is not a subset of current range of 'breaks'", call.=FALSE) newmid <- breaks[-length(breaks)] + diff(breaks)/2 newout <- x(newmid) result <- colourmap(newout, breaks=breaks) } return(result) } as.colourmap <- function(x, ...) { UseMethod("as.colourmap") } as.colourmap.colourmap <- function(x, ...) { x } spatstat.geom/R/flipxy.R0000644000176200001440000000250614611065352014710 0ustar liggesusers# # flipxy.R # # flip x and y coordinates # # $Revision: 1.4 $ $Date: 2024/02/04 08:04:51 $ # flipxy <- function(X) { UseMethod("flipxy") } flipxy.ppp <- function(X) { stopifnot(is.ppp(X)) ppp(X$y, X$x, marks=X$marks, window=flipxy(X$window), unitname=unitname(X), check=FALSE) } flipxypolygon <- function(p) { # flip x and y coordinates, and reinstate anticlockwise order oldy <- p$y p$y <- rev(p$x) p$x <- rev(oldy) # area and hole status unchanged return(p) } flipxy.owin <- function(X) { verifyclass(X, "owin") switch(X$type, rectangle={ W <- owinInternalRect(X$yrange, X$xrange, unitname=unitname(X)) }, polygonal={ bdry <- lapply(X$bdry, flipxypolygon) W <- owin(poly=bdry, check=FALSE, unitname=unitname(X)) }, mask={ W <- owin(mask=t(X$m), xy=list(x=X$yrow, y=X$xcol), unitname=unitname(X)) }, stop("Unrecognised window type") ) return(W) } flipxy.psp <- function(X) { stopifnot(is.psp(X)) flipends <- (X$ends)[, c(2L,1L,4L,3L), drop=FALSE] as.psp(flipends, window=flipxy(X$window), marks=X$marks, unitname=unitname(X), check=FALSE) } flipxy.im <- function(X) { im(t(X$v), xcol=X$yrow, yrow=X$xcol, unitname=unitname(X)) } spatstat.geom/R/pickoption.R0000644000176200001440000000247614611065352015562 0ustar liggesusers# # pickoption.R # # $Revision: 1.7 $ $Date: 2019/06/30 07:49:10 $ # pickoption <- function(what="option", key, keymap, ..., exact=FALSE, list.on.err=TRUE, die=TRUE, multi=FALSE, allow.all=TRUE) { keyname <- short.deparse(substitute(key)) if(!is.character(key)) stop(paste(keyname, "must be a character string", if(multi) "or strings" else NULL)) if(length(key) == 0) stop(paste("Argument", sQuote(keyname), "has length zero")) key <- unique(key) if(!multi && length(key) > 1) stop(paste("Must specify only one", what, sQuote(keyname))) allow.all <- allow.all && multi id <- if(allow.all && "all" %in% key) { seq_along(keymap) } else if(exact) { match(key, names(keymap), nomatch=NA) } else { pmatch(key, names(keymap), nomatch=NA) } if(any(nbg <- is.na(id))) { # no match whinge <- paste("unrecognised", what, paste(dQuote(key[nbg]), collapse=", "), "in argument", sQuote(keyname)) if(list.on.err) { cat(paste(whinge, "\n", "Options are:"), paste(dQuote(names(keymap)), collapse=","), "\n") } if(die) stop(whinge, call.=FALSE) else return(NULL) } key <- unique(keymap[id]) names(key) <- NULL return(key) } spatstat.geom/R/pppmatch.R0000644000176200001440000007334514611065352015222 0ustar liggesusers# # pppmatch.R # # $Revision: 1.27 $ $Date: 2022/05/21 09:52:11 $ # # Code by Dominic Schuhmacher # # # ----------------------------------------------------------------- # The standard functions for the new class pppmatching # # Objects of class pppmatching consist of two point patterns pp1 and pp2, # and either an adjacency matrix ((i,j)-th entry 1 if i-th point of pp1 and j-th # point of pp2 are matched, 0 otherwise) for "full point matchings" or # a "generalized adjacency matrix" (or flow matrix; positive values are # no longer limited to 1, (i,j)-th entry gives the "flow" between # the i-th point of pp1 and the j-th point of pp2) for "fractional matchings". # Optional elements are the type # of the matching, the cutoff value for distances in R^2, the order # of averages taken, and the resulting distance for the matching. # Currently recognized types are "spa" (subpattern assignment, # where dummy points at maximal dist are introduced if cardinalities differ), # "ace" (assignment if cardinalities equal, where dist is maximal if cards differ), # and "mat" (mass transfer, fractional matching that belongs to the # Wasserstein distance obtained if point patterns are normalized to probability measures). # ----------------------------------------------------------------- pppmatching <- function(X, Y, am, type = NULL, cutoff = NULL, q = NULL, mdist = NULL) { verifyclass(X, "ppp") verifyclass(Y, "ppp") n1 <- X$n n2 <- Y$n am <- as.matrix(am) if (length(am) == 0) { if (min(n1,n2) == 0) am <- matrix(am, nrow=n1, ncol=n2) else stop("Adjacency matrix does not have the right dimensions") } if (dim(am)[1] != n1 || dim(am)[2] != n2) stop("Adjacency matrix does not have the right dimensions") am <- matrix(as.numeric(am), n1, n2) #am <- apply(am, c(1,2), as.numeric) res <- list("pp1" = X, "pp2" = Y, "matrix" = am, "type" = type, "cutoff" = cutoff, "q" = q, "distance" = mdist) class(res) <- "pppmatching" res } plot.pppmatching <- function(x, addmatch = NULL, main = NULL, ..., adjust=1) { if (is.null(main)) main <- short.deparse(substitute(x)) pp1 <- x$pp1 pp2 <- x$pp2 do.call.matched(plot.owin, list(x=pp1$window, main = main, ...), extrargs=graphicsPars("owin")) here <- which((x$matrix > 0), arr.ind = TRUE) if (!is.null(addmatch)) { stopifnot(is.matrix(addmatch)) addhere <- which((addmatch > 0), arr.ind = TRUE) seg <- as.psp(from=pp1[addhere[,1]], to=pp2[addhere[,2]]) plot(seg, add=TRUE, lty = 2, col="gray70") } if (length(here) > 0) { seg <- as.psp(from=pp1[here[,1]], to=pp2[here[,2]]) marks(seg) <- x$matrix[here] plot(seg, add=TRUE, ..., style="width", adjust=adjust) } plot(x$pp1, add=TRUE, pch=20, col=2, ...) plot(x$pp2, add=TRUE, pch=20, col=4, ...) return(invisible(NULL)) } print.pppmatching <- function(x, ...) { n1 <- x$pp1$n n2 <- x$pp2$n if (is.null(x$type) || is.null(x$q) || is.null(x$cutoff)) splat("Generic matching of two planar point patterns") else splat(x$type, "-", x$q, " matching of two planar point patterns (cutoff = ", x$cutoff, ")", sep = "") splat("pp1:", n1, ngettext(n1, "point", "points")) splat("pp2:", n2, ngettext(n2, "point", "points")) print(Window(x$pp1)) npair <- sum(x$matrix > 0) if (npair == 0) splat("matching is empty") else { if (any(x$matrix != trunc(x$matrix))) splat("fractional matching,", npair, ngettext(npair, "flow", "flows")) else splat("point matching,", npair, ngettext(npair, "line", "lines")) } if (!is.null(x$distance)) splat("distance:", x$distance) return(invisible(NULL)) } summary.pppmatching <- function(object, ...) { X <- object$pp1 Y <- object$pp2 n1 <- X$n n2 <- Y$n if (is.null(object$type) || is.null(object$q) || is.null(object$cutoff)) splat("Generic matching of two planar point patterns") else splat(object$type, "-", object$q, " matching of two planar point patterns (cutoff = ", object$cutoff, ")", sep = "") splat("pp1:", n1, ngettext(n1, "point", "points")) splat("pp2:", n2, ngettext(n2, "point", "points")) print(Window(X)) npair <- sum(object$matrix > 0) if (npair == 0) splat("matching is empty") else { if (any(object$matrix != trunc(object$matrix))) { splat("fractional matching,", npair, ngettext(npair, "flow", "flows")) } else { splat("point matching,", npair, ngettext(npair, "line", "lines")) rowsum <- rowSums(object$matrix) colsum <- colSums(object$matrix) lt <- ifelse(min(rowsum) >= 1, TRUE, FALSE) ru <- ifelse(max(rowsum) <= 1, TRUE, FALSE) rt <- ifelse(min(colsum) >= 1, TRUE, FALSE) lu <- ifelse(max(colsum) <= 1, TRUE, FALSE) if (lt && ru && rt && lu) splat("matching is 1-1") else if (any(lt, ru, rt, lu)) { splat("matching is", ifelse(lt, " left-total", ""), ifelse(lu, " left-unique", ""), ifelse(rt, " right-total", ""), ifelse(ru, " right-unique", ""), sep="") } } } if (!is.null(object$distance)) splat("distance:", object$distance) return(invisible(NULL)) } # ----------------------------------------------------------------- # matchingdist computes the distance associated with a certain kind of matching. # Any of the arguments type, cutoff and order (if supplied) override the # the corresponding arguments in the matching. # This function is useful for verifying the distance element of an # object of class pppmatching as well as for comparing different # (typically non-optimal) matchings. # ----------------------------------------------------------------- matchingdist <- function(matching, type = NULL, cutoff = NULL, q = NULL) { verifyclass(matching, "pppmatching") if (is.null(type)) if (is.null(matching$type)) stop("Type of matching unknown. Distance cannot be computed") else type <- matching$type if (is.null(cutoff)) if (is.null(matching$cutoff)) stop("Cutoff value unknown. Distance cannot be computed") else cutoff <- matching$cutoff if (is.null(q)) if (is.null(matching$q)) stop("Order unknown. Distance cannot be computed") else q <- matching$q X <- matching$pp1 Y <- matching$pp2 n1 <- X$n n2 <- Y$n Lpexpect <- function(x, w, p) { f <- max(x) return(ifelse(f==0, 0, f * sum((x/f)^p * w)^(1/p))) } if (type == "spa") { n <- max(n1,n2) # divisor for Lpexpect if (n == 0) return(0) else if (min(n1,n2) == 0) return(cutoff) shortdim <- which.min(c(n1,n2)) shortsum <- apply(matching$matrix, shortdim, sum) if (any(shortsum != 1)) warning("matching does not attribute mass 1 to each point of point pattern with smaller cardinality") # dfix <- apply(crossdist(X,Y), c(1,2), function(x) { min(x,cutoff) }) dfix <- pmin(crossdist(X,Y), cutoff) if (is.finite(q)) resdist <- (Lpexpect(dfix, matching$matrix/n, q)^q + abs(n2-n1)/n * cutoff^q)^(1/q) else resdist <- ifelse(n1==n2, max(dfix[matching$matrix > 0]), cutoff) } else if (type == "ace") { n <- n1 # divisor for Lpexpect if (n1 != n2) return(cutoff) if (n == 0) return(0) rowsum <- rowSums(matching$matrix) colsum <- colSums(matching$matrix) if (any(c(rowsum, colsum) != 1)) warning("matching is not 1-1") # dfix <- apply(crossdist(X,Y), c(1,2), function(x) { min(x,cutoff) }) dfix <- pmin(crossdist(X,Y), cutoff) if (is.finite(q)) resdist <- Lpexpect(dfix, matching$matrix/n, q) else resdist <- max(dfix[matching$matrix > 0]) } else if (type == "mat") { n <- min(n1,n2) # divisor for Lpexpect if (min(n1,n2) == 0) return(NaN) shortdim <- which.min(c(n1,n2)) shortsum <- apply(matching$matrix, shortdim, sum) if (any(shortsum != 1)) warning("matching does not attribute mass 1 to each point of point pattern with smaller cardinality") # dfix <- apply(crossdist(X,Y), c(1,2), function(x) { min(x,cutoff) }) dfix <- pmin(crossdist(X,Y), cutoff) if (is.finite(q)) resdist <- Lpexpect(dfix, matching$matrix/n, q) else resdist <- max(dfix[matching$matrix > 0]) } else stop(paste("Unrecognised type", sQuote(type))) return(resdist) } # ----------------------------------------------------------------- # The main function for computation of distances and finding optimal # matchings between point patterns: pppdist # ----------------------------------------------------------------- # # pppdist uses several helper functions not normally called by the user # # The arguments of pppdist are # # x and y of class ppp (the two point patterns for which we want to compute # a distance) # The type of distance to be computed; any one of "spa" (default), "ace", "mat". # For details of this and the following two arguments see above (description # for class "pppmatching") # cutoff and order q of the distance # Set matching to TRUE if the full point matching (including distance) # should be returned; otherwise only the distance is returned # If ccode is FALSE R code is used where available. This may be useful if q # is high (say above 10) and severe warning messages pop up. R can # (on most machines) deal with a higher number of significant digits per # number than C (at least with the code used below) # precision should only be entered by advanced users. Empirically reasonable defaults # are used otherwise. As a rule of thumb, if ccode is TRUE, precision should # be the highest value that does not give an error (typically 9); if ccode # is FALSE, precision should be balanced (typically between 10 and 100) in # such a way that the sum of the number of zeroes and pseudo-zeroes given in the # warning messages is minimal # approximation: if q = Inf, by the distance of which order should # the true distance be approximated. If approximation is Inf, brute force # computation is used, which is only practicable for point patterns with # very few points (see also the remarks just before the pppdist.prohorov # function below). # show.rprimal=TRUE shows at each stage of the algorithm what the current restricted # primal problem and its solution are (algorithm jumps between restricted primal # and dual problem until the solution to the restricted primal (a partial # matching of the point patterns) is a full matching) # timelag gives the number of seconds of pause added each time a solution to # the current restricted primal is found (has only an effect if show.primal=TRUE) # ----------------------------------------------------------------- pppdist <- function(X, Y, type = "spa", cutoff = 1, q = 1, matching = TRUE, ccode = TRUE, auction = TRUE, precision = NULL, approximation = 10, show.rprimal = FALSE, timelag = 0) { verifyclass(X, "ppp") verifyclass(Y, "ppp") if (!ccode && type == "mat") { warning("R code is not available for type = ", dQuote("mat"), ". C code is used instead") ccode <- TRUE } if (!ccode && is.infinite(q) && is.infinite(approximation)) { warning("R code is not available for q = Inf and approximation = Inf. C code is used instead") ccode <- TRUE } if (ccode && is.infinite(q) && is.infinite(approximation) && type == "spa" && X$n != Y$n) { warning("approximation = Inf not available for type = ", dQuote("spa"), " and point patterns with differing cardinalities") approximation <- 10 } if (is.infinite(q) && is.infinite(approximation) && type == "mat") { warning("approximation = Inf not available for type = ", dQuote("mat")) approximation <- 10 } if (show.rprimal) { ccode <- FALSE auction <- FALSE if (type != "ace"){ warning("show.rprimal = TRUE not available for type = ", dQuote(type), ". Type is changed to ", dQuote("ace")) type <- "ace" } } if (is.null(precision)) { if (ccode) precision <- trunc(log10(.Machine$integer.max)) else { db <- .Machine$double.base minprec <- trunc(log10(.Machine$double.base^.Machine$double.digits)) if (is.finite(q)) precision <- min(max(minprec,2*q), (.Machine$double.max.exp-1)*log(db)/log(10)) else precision <- min(max(minprec,2*approximation), (.Machine$double.max.exp-1)*log(db)/log(10)) } } if (type == "spa") { if (X$n == 0 && Y$n == 0) { if (!matching) return(0) else { return(pppmatching(X, Y, matrix(0, nrow=0,ncol=0), type, cutoff, q, 0)) } } n1 <- X$n n2 <- Y$n n <- max(n1,n2) dfix <- matrix(cutoff,n,n) if (min(n1,n2) > 0) dfix[1:n1,1:n2] <- crossdist(X,Y) # d <- dfix <- apply(dfix, c(1,2), function(x) { min(x,cutoff) }) d <- dfix <- pmin(dfix,cutoff) if (is.infinite(q)) { if (n1 == n2 || matching) return(pppdist.prohorov(X, Y, n, d, type, cutoff, matching, ccode, auction, precision, approximation)) else return(cutoff) # in the case n1 != n2 the distance is clear, and in a sense any # matching would be correct. We go here the extra mile and call # pppdist.prohorov in order to find (approximate) the matching # that is intuitively most interesting (i.e. the one that # pairs the points of the # smaller cardinality point pattern with the points of the larger # cardinality point pattern in such a way that the maximal pairing distance # is minimal (for q < Inf the q-th order pairing distance before the introduction # of dummy points is automatically minimal if it is minimal after the # introduction of dummy points) # which would be the case for the obtained pairing if q < Inf } } else if (type == "ace") { if (X$n != Y$n) { if (!matching) return(cutoff) else { return(pppmatching(X, Y, matrix(0, nrow=X$n, ncol=Y$n), type, cutoff, q, cutoff)) } } if (X$n == 0) { if (!matching) return(0) else { return(pppmatching(X, Y, matrix(0, nrow=0,ncol=0), type, cutoff, q, 0)) } } n <- n1 <- n2 <- X$n dfix <- crossdist(X,Y) # d <- dfix <- apply(dfix, c(1,2), function(x) { min(x,cutoff) }) d <- dfix <- pmin(dfix, cutoff) if (is.infinite(q)) return(pppdist.prohorov(X, Y, n, d, type, cutoff, matching, ccode, auction, precision, approximation)) } else if (type == "mat") { if (!ccode) warning("R code is not available for type = ", dQuote("mat"), ". C code is used instead") if (auction) warning("Auction algorithm is not available for type = ", dQuote("mat"), ". Primal-dual algorithm is used instead") return(pppdist.mat(X, Y, cutoff, q, matching, precision, approximation)) } else stop(paste("Unrecognised type", sQuote(type))) d <- d/max(d) d <- round((d^q)*(10^precision)) nzeroes <- sum(d == 0 & dfix > 0) if(nzeroes > 0) warning(paste(nzeroes, ngettext(nzeroes, "zero", "zeroes"), "introduced, while rounding the q-th powers of distances")) if(ccode & any(d > .Machine$integer.max)) stop("integer overflow, while rounding the q-th powers of distances") if(!ccode) { if (any(is.infinite(d))) stop("Inf obtained, while taking the q-th powers of distances") maxd <- max(d) npszeroes <- sum(maxd/d[d>0] >= .Machine$double.base^.Machine$double.digits) if (npszeroes > 0) warning(paste(npszeroes, ngettext(npszeroes, "pseudo-zero", "pseudo-zeroes"), "introduced, while taking the q-th powers of distances")) # a pseudo-zero is a value that is positive but contributes nothing to the # q-th order average because it is too small compared to the other values } Lpmean <- function(x, p) { f <- max(x) return(ifelse(f==0, 0, f * mean((x/f)^p)^(1/p))) } if (show.rprimal && type == "ace") { assig <- acedist.show(X, Y, n, d, timelag) am <- matrix(0, n, n) am[cbind(1:n, assig[1:n])] <- 1 } else if (ccode) { if (auction) { dupper <- max(d)/10 lasteps <- 1/(n+1) epsfac <- 10 epsvec <- lasteps ## Bertsekas: from dupper/2 to 1/(n+1) divide repeatedly by a constant while (lasteps < dupper) { lasteps <- lasteps*epsfac epsvec <- c(epsvec,lasteps) } epsvec <- rev(epsvec)[-1] neps <- length(epsvec) stopifnot(neps >= 1) d <- max(d)-d ## auctionbf uses a "desire matrix" res <- .C(SG_auctionbf, as.integer(d), as.integer(n), pers_to_obj = as.integer(rep(-1,n)), price = as.double(rep(0,n)), profit = as.double(rep(0,n)), as.integer(neps), as.double(epsvec), PACKAGE="spatstat.geom") am <- matrix(0, n, n) am[cbind(1:n,res$pers_to_obj+1)] <- 1 } else { res <- .C(SG_dwpure, as.integer(d), as.integer(rep.int(1,n)), as.integer(rep.int(1,n)), as.integer(n), as.integer(n), flowmatrix = as.integer(integer(n^2)), PACKAGE="spatstat.geom") am <- matrix(res$flowmatrix, n, n) } } else { assig <- acedist.noshow(X, Y, n, d) am <- matrix(0, n, n) am[cbind(1:n, assig[1:n])] <- 1 } resdist <- Lpmean(dfix[am == 1], q) if (!matching) return(resdist) else { amsmall <- suppressWarnings(matrix(am[1:n1,1:n2], nrow=n1, ncol=n2)) # previous line solves various problems associated with min(n1,n2) = 0 or = 1 return(pppmatching(X, Y, amsmall, type, cutoff, q, resdist)) } } # # # =========================================================== # =========================================================== # Anything below: # Internal functions usually not to be called by user # =========================================================== # =========================================================== # # # Called if show.rprimal is true # acedist.show <- function(X, Y, n, d, timelag = 0) { plot(pppmatching(X, Y, matrix(0, n, n))) # initialization of dual variables u <- apply(d, 1, min) d <- d - u v <- apply(d, 2, min) d <- d - rep(v, each=n) # the main loop feasible <- FALSE while (!feasible) { rpsol <- maxflow(d) # rpsol = restricted primal, solution am <- matrix(0, n, n) for (i in 1:n) { if (rpsol$assignment[i] > -1) am[i, rpsol$assignment[i]] <- TRUE } Sys.sleep(timelag) channelmat <- (d == 0 & !am) plot(pppmatching(X, Y, am), addmatch = channelmat) # if the solution of the restricted primal is not feasible for # the original primal, update dual variables if (min(rpsol$assignment) == -1) { w1 <- which(rpsol$fi_rowlab > -1) w2 <- which(rpsol$fi_collab == -1) subtractor <- min(d[w1, w2]) d[w1,] <- d[w1,] - subtractor d[,-w2] <- d[,-w2] + subtractor } # otherwise break the loop else { feasible <- TRUE } } return(rpsol$assignment) } # # R-version of hungarian algo without the pictures # useful if q is large # acedist.noshow <- function(X, Y, n, d) { # initialization of dual variables u <- apply(d, 1, min) d <- d - u v <- apply(d, 2, min) d <- d - rep(v, each=n) # the main loop feasible <- FALSE while (!feasible) { rpsol <- maxflow(d) # rpsol = restricted primal, solution # ~~~~~~~~~ deleted by AJB ~~~~~~~~~~~~~~~~~ # am <- matrix(0, n, n) # for (i in 1:n) { # if (rpsol$assignment[i] > -1) am[i, rpsol$assignment[i]] <- TRUE # } # channelmat <- (d == 0 & !am) # ~~~~~~~~~~~~~~~~~~~~~~~~~~ # if the solution of the restricted primal is not feasible for # the original primal, update dual variables if (min(rpsol$assignment) == -1) { w1 <- which(rpsol$fi_rowlab > -1) w2 <- which(rpsol$fi_collab == -1) subtractor <- min(d[w1, w2]) d[w1,] <- d[w1,] - subtractor d[,-w2] <- d[,-w2] + subtractor } # otherwise break the loop else { feasible <- TRUE } } return(rpsol$assignment) } # # Solution of restricted primal # maxflow <- function(costm) { stopifnot(is.matrix(costm)) stopifnot(nrow(costm) == ncol(costm)) if(!all(apply(costm == 0, 1, any))) stop("Each row of the cost matrix must contain a zero") m <- dim(costm)[1] # cost matrix is square m * m assignment <- rep.int(-1, m) # -1 means no pp2-point assigned to i-th pp1-point ## initial assignment or rowlabel <- source label (= 0) where not possible for (i in 1:m) { j <- match(0, costm[i,]) if (!(j %in% assignment)) assignment[i] <- j } newlabelfound <- TRUE while (newlabelfound) { rowlab <- rep.int(-1, m) # -1 means no label given, 0 stands for source label collab <- rep.int(-1, m) rowlab <- ifelse(assignment == -1, 0, rowlab) ## column and row labeling procedure until either breakthrough occurs ## (which means that there is a better point assignment, i.e. one that ## creates more point pairs than the current one (flow can be increased)) ## or no more labeling is possible breakthrough <- -1 while (newlabelfound && breakthrough == -1) { newlabelfound <- FALSE for (i in 1:m) { if (rowlab[i] != -1) { for (j in 1:m) { if (costm[i,j] == 0 && collab[j] == -1) { collab[j] <- i newlabelfound <- TRUE if (!(j %in% assignment) && breakthrough == -1) breakthrough <- j } } } } for (j in 1:m) { if (collab[j] != -1) { for (i in 1:m) { if (assignment[i] == j && rowlab[i] == -1) { rowlab[i] <- j newlabelfound <- TRUE } } } } } ## if the while-loop was left due to breakthrough, ## reassign points (i.e. redirect flow) and restart labeling procedure if (breakthrough != -1) { l <- breakthrough while (l != 0) { k <- collab[l] assignment[k] <- l l <- rowlab[k] } } } ## the outermost while-loop is left, no more labels can be given; hence ## the maximal number of points are paired given the current restriction ## (flow is maximal given the current graph) return(list("assignment"=assignment, "fi_rowlab"=rowlab, "fi_collab"=collab)) } # # Prohorov distance computation/approximation (called if q = Inf in pppdist # and type = "spa" or "ace") # Exact brute force computation of distance if approximation = Inf, # scales very badly, should not be used for cardinality n larger than 10-12 # Approximation by order q distance gives often (if the warning messages # are not too extreme) the right matching and therefore the exact Prohorov distance, # but in very rare cases the result can be very wrong. However, it is always # an exact upper bound of the Prohorov distance (since based on *a* pairing # as opposed to optimal pairing. # pppdist.prohorov <- function(X, Y, n, dfix, type, cutoff = 1, matching = TRUE, ccode = TRUE, auction = TRUE, precision = 9, approximation = 10) { n1 <- X$n n2 <- Y$n d <- dfix/max(dfix) if (is.finite(approximation)) { warning(paste("distance with parameter q = Inf is approximated by distance with parameter q =", approximation)) d <- round((d^approximation)*(10^precision)) nzeroes <- sum(d == 0 & dfix > 0) if (nzeroes > 0) warning(paste(nzeroes, ngettext(nzeroes, "zero", "zeroes"), "introduced, while rounding distances")) if (ccode) { if (any(d > .Machine$integer.max)) stop("integer overflow, while rounding the q-th powers of distances") if (auction) { dupper <- max(d)/10 lasteps <- 1/(n+1) epsfac <- 10 epsvec <- lasteps ## Bertsekas: from dupper/2 to 1/(n+1) divide repeatedly by a constant while (lasteps < dupper) { lasteps <- lasteps*epsfac epsvec <- c(epsvec,lasteps) } epsvec <- rev(epsvec)[-1] neps <- length(epsvec) stopifnot(neps >= 1) d <- max(d)-d ## auctionbf uses a "desire matrix" res <- .C(SG_auctionbf, as.integer(d), as.integer(n), pers_to_obj = as.integer(rep(-1,n)), price = as.double(rep(0,n)), profit = as.double(rep(0,n)), as.integer(neps), as.double(epsvec), PACKAGE="spatstat.geom") am <- matrix(0, n, n) am[cbind(1:n,res$pers_to_obj+1)] <- 1 } else { res <- .C(SG_dwpure, as.integer(d), as.integer(rep.int(1,n)), as.integer(rep.int(1,n)), as.integer(n), as.integer(n), flowmatrix = as.integer(integer(n^2)), PACKAGE="spatstat.geom") am <- matrix(res$flowmatrix, n, n) } } else { if (any(is.infinite(d))) stop("Inf obtained, while taking the q-th powers of distances") maxd <- max(d) npszeroes <- sum(maxd/d[d>0] >= .Machine$double.base^.Machine$double.digits) if (npszeroes > 0) warning(paste(npszeroes, ngettext(npszeroes, "pseudo-zero", "pseudo-zeroes"), "introduced, while taking the q-th powers of distances")) assig <- acedist.noshow(X, Y, n, d) am <- matrix(0, n, n) am[cbind(1:n, assig[1:n])] <- 1 } } else { d <- round(d*(10^precision)) nzeroes <- sum(d == 0 & dfix > 0) if (nzeroes > 0) warning(paste(nzeroes, ngettext(nzeroes, "zero", "zeroes"), "introduced, while rounding distances")) if (any(d > .Machine$integer.max)) stop("integer overflow, while rounding the q-th powers of distances") res <- .C(SG_dinfty_R, as.integer(d), as.integer(n), assignment = as.integer(rep.int(-1,n)), PACKAGE="spatstat.geom") assig <- res$assignment am <- matrix(0, n, n) am[cbind(1:n, assig[1:n])] <- 1 } if (n1 == n2) resdist <- max(dfix[am == 1]) else resdist <- cutoff if (!matching) return(resdist) else { amsmall <- suppressWarnings(matrix(am[1:n1,1:n2], nrow=n1, ncol=n2)) ## previous line solves various problems associated with min(n1,n2) = 0 or = 1 return(pppmatching(X, Y, amsmall, type, cutoff, Inf, resdist)) } } # # Computation of "pure Wasserstein distance" for any q (called if type="mat" # in pppdist, no matter if q finite or not). # If q = Inf, approximation using ccode is enforced # (approximation == Inf is not allowed here). # pppdist.mat <- function(X, Y, cutoff = 1, q = 1, matching = TRUE, precision = 9, approximation = 10) { n1 <- X$n n2 <- Y$n n <- min(n1,n2) if (n == 0) { if (!matching) return(NaN) else return(pppmatching(X, Y, matrix(0, nrow=0,ncol=0), "mat", cutoff, q, NaN)) } dfix <- crossdist(X,Y) # d <- dfix <- apply(dfix, c(1,2), function(x) { min(x,cutoff) }) d <- dfix <- pmin(dfix, cutoff) d <- d/max(d) if (is.infinite(q)) { if (is.infinite(approximation)) stop("approximation = Inf") warning(paste("distance with parameter q = Inf is approximated by distance with parameter q =", approximation)) d <- round((d^approximation)*(10^precision)) nzeroes <- sum(d == 0 & dfix > 0) if (nzeroes > 0) warning(paste(nzeroes, "zeroes introduced, while rounding distances")) if (any(d > .Machine$integer.max)) stop("integer overflow, while rounding the q-th powers of distances") gcd <- greatest.common.divisor(n1,n2) mass1 <- n2/gcd mass2 <- n1/gcd res <- .C(SG_dwpure, as.integer(d), as.integer(rep.int(mass1,n1)), as.integer(rep.int(mass2,n2)), as.integer(n1), as.integer(n2), flowmatrix = as.integer(integer(n1*n2)), PACKAGE="spatstat.geom") am <- matrix(res$flowmatrix/(max(n1,n2)/gcd), n1, n2) resdist <- max(dfix[am > 0]) } else { d <- round((d^q)*(10^precision)) nzeroes <- sum(d == 0 & dfix > 0) if(nzeroes > 0) warning(paste(nzeroes, ngettext(nzeroes, "zero", "zeroes"), "introduced, while rounding the q-th powers of distances")) if(any(d > .Machine$integer.max)) stop("integer overflow, while rounding the q-th powers of distances") gcd <- greatest.common.divisor(n1,n2) mass1 <- n2/gcd mass2 <- n1/gcd Lpexpect <- function(x, w, p) { f <- max(x) return(ifelse(f==0, 0, f * sum((x/f)^p * w)^(1/p))) } res <- .C(SG_dwpure, as.integer(d), as.integer(rep.int(mass1,n1)), as.integer(rep.int(mass2,n2)), as.integer(n1), as.integer(n2), flowmatrix = as.integer(integer(n1*n2)), PACKAGE="spatstat.geom") am <- matrix(res$flowmatrix/(max(n1,n2)/gcd), n1, n2) # our "adjacency matrix" in this case is standardized to have # rowsum 1 if n1 <= n2 and colsum 1 if n1 >= n2 resdist <- Lpexpect(dfix, am/n, q) } if (!matching) return(resdist) else { amsmall <- suppressWarnings(matrix(am[1:n1,1:n2], nrow=n1, ncol=n2)) # previous line solves various problems associated with min(n1,n2) = 0 or = 1 return(pppmatching(X, Y, amsmall, "mat", cutoff, q, resdist)) } } spatstat.geom/R/quadclass.R0000644000176200001440000002070214611065352015353 0ustar liggesusers# # quadclass.S # # Class 'quad' to define quadrature schemes # in (rectangular) windows in two dimensions. # # $Revision: 4.29 $ $Date: 2020/11/18 03:07:14 $ # # An object of class 'quad' contains the following entries: # # $data: an object of class 'ppp' # defining the OBSERVATION window, # giving the locations (& marks) of the data points. # # $dummy: object of class 'ppp' # defining the QUADRATURE window, # giving the locations (& marks) of the dummy points. # # $w: vector giving the nonnegative weights for the # data and dummy points (data first, followed by dummy) # # w may also have an attribute attr(w, "zeroes") # equivalent to (w == 0). If this is absent # then all points are known to have positive weights. # # $param: # parameters that were used to compute the weights # and possibly to create the dummy points (see below). # # The combined (data+dummy) vectors of x, y coordinates of the points, # and their weights, are extracted using standard functions # x.quad(), y.quad(), w.quad() etc. # # ---------------------------------------------------------------------- # Note about parameters: # # If the quadrature scheme was created by quadscheme(), # then $param contains # # $param$weight # list containing the values of all parameters # actually used to compute the weights. # # $param$dummy # list containing the values of all parameters # actually used to construct the dummy pattern # via default.dummy(); # or NULL if the dummy pattern was provided externally # # $param$sourceid # vector mapping the quadrature points to the # original data and dummy points. # # If you constructed the quadrature scheme manually, this # structure may not be present. # #------------------------------------------------------------- quad <- function(data, dummy, w, param=NULL) { data <- as.ppp(data) dummy <- as.ppp(dummy) n <- data$n + dummy$n if(missing(w)) w <- rep.int(1, n) else { w <- as.vector(w) if(length(w) != n) stop("length of weights vector w is not equal to total number of points") } if(is.null(attr(w, "zeroes")) && any( w == 0)) attr(w, "zeroes") <- (w == 0) Q <- list(data=data, dummy=dummy, w=w, param=param) class(Q) <- "quad" invisible(Q) } is.quad <- function(x) { inherits(x, "quad") } # ------------------ extractor functions ---------------------- x.quad <- function(Q) { verifyclass(Q, "quad") c(Q$data$x, Q$dummy$x) } y.quad <- function(Q) { verifyclass(Q, "quad") c(Q$data$y, Q$dummy$y) } coords.quad <- function(x, ...) { data.frame(x=x.quad(x), y=y.quad(x)) } w.quad <- function(Q) { verifyclass(Q, "quad") Q$w } param.quad <- function(Q) { verifyclass(Q, "quad") Q$param } n.quad <- function(Q) { verifyclass(Q, "quad") Q$data$n + Q$dummy$n } marks.quad <- function(x, dfok=FALSE, ...) { verifyclass(x, "quad") dat <- x$data dum <- x$dummy if(dfok) warning("ignored dfok = TRUE; not implemented") mdat <- marks(dat, dfok=FALSE, ...) mdum <- marks(dum, dfok=FALSE, ...) if(is.null(mdat) && is.null(mdum)) return(NULL) if(is.null(mdat)) mdat <- rep.int(NA_integer_, dat$n) if(is.null(mdum)) mdum <- rep.int(NA_integer_, dum$n) if(is.factor(mdat) && is.factor(mdum)) { mall <- cat.factor(mdat, mdum) } else mall <- c(mdat, mdum) return(mall) } is.marked.quad <- function(X, na.action="warn", ...) { marx <- marks(X, ...) if(is.null(marx)) return(FALSE) if(anyNA(marx)) switch(na.action, warn = { warning(paste("some mark values are NA in the point pattern", short.deparse(substitute(X)))) }, fatal = { return(FALSE) }, ignore = {} ) return(TRUE) } is.multitype.quad <- function(X, na.action="warn", ...) { marx <- marks(X, ...) if(is.null(marx)) return(FALSE) if(anyNA(marx)) switch(na.action, warn = { warning(paste("some mark values are NA in the point pattern", short.deparse(substitute(X)))) }, fatal = { return(FALSE) }, ignore = {} ) return(!is.data.frame(marx) && is.factor(marx)) } is.data <- function(Q) { verifyclass(Q, "quad") return(c(rep.int(TRUE, Q$data$n), rep.int(FALSE, Q$dummy$n))) } equals.quad <- function(Q) { # return matrix E such that E[i,j] = (X[i] == U[j]) # where X = Q$data and U = union.quad(Q) n <- Q$data$n m <- Q$dummy$n E <- matrix(FALSE, nrow=n, ncol=n+m) diag(E) <- TRUE E } equalsfun.quad <- function(Q) { stopifnot(inherits(Q, "quad")) return(function(i,j) { i == j }) } equalpairs.quad <- function(Q) { # return two-column matrix E such that # X[E[i,1]] == U[E[i,2]] for all i # where X = Q$data and U = union.quad(Q) n <- Q$data$n return(matrix(rep.int(seq_len(n),2), ncol=2)) } union.quad <- function(Q) { verifyclass(Q, "quad") ppp(x= c(Q$data$x, Q$dummy$x), y= c(Q$data$y, Q$dummy$y), window=Q$dummy$window, marks=marks.quad(Q), check=FALSE) } # # Plot a quadrature scheme # # plot.quad <- function(x, ..., main, add=FALSE, dum=list(), tiles=FALSE) { if(missing(main) || is.null(main)) main <- short.deparse(substitute(x)) verifyclass(x, "quad") data <- x$data dummy <- x$dummy # determine plot parameters for dummy points dum <- resolve.defaults(dum, list(pch=".", add=TRUE)) tt <- NULL if(tiles) { # show tiles that determined the weights wp <- x$param$weight tt <- NULL if(is.null(wp) || is.null(wp$method)) { warning("Tile information is not available") } else { switch(wp$method, grid = { ntile <- wp$ntile tt <- quadrats(as.owin(x), ntile[1], ntile[2]) }, dirichlet = { U <- union.quad(x) if(wp$exact) { tt <- dirichlet(U) } else { win <- as.mask(as.owin(U)) tileid <- im(exactdt(U)$i, win$xcol, win$yrow, win$xrange, win$yrange) tt <- tess(image=tileid[win, drop=FALSE]) } }, warning("Unrecognised 'method' for tile weights") ) } } pixeltiles <- !is.null(tt) && tt$type == "image" tileargs <- resolve.defaults(list(x=quote(tt), main=main, add=add), list(...), if(!pixeltiles) list(col="grey") else NULL) if(!is.marked(data)) { if(!is.null(tt)) { do.call(plot, tileargs) add <- TRUE } plot(data, main=main, add=add, ...) do.call(plot, append(list(x=dummy), dum)) } else if(is.multitype(data) && !add) { oldpar <- par(ask = interactive() && (.Device %in% c("X11", "GTK", "windows", "Macintosh"))) on.exit(par(oldpar)) data.marks <- marks(data) dummy.marks <- marks(dummy) types <- levels(data.marks) for(k in types) { add <- FALSE if(!is.null(tt)) { do.call(plot, tileargs) add <- TRUE } maink <- paste(main, "\n mark = ", k, sep="") plot(unmark(data[data.marks == k]), main=maink, add=add, ...) do.call(plot, append(list(x=unmark(dummy[dummy.marks == k])), dum)) } } else { if(!is.null(tt)) { do.call(plot, tileargs) add <- TRUE } plot(data, ..., main=main, add=add) do.call(plot, append(list(x=dummy), dum)) } invisible(NULL) } # subset operator "[.quad" <- function(x, ...) { U <- union.quad(x) Z <- is.data(x) w <- w.quad(x) # determine serial numbers of points to be included V <- U %mark% seq_len(U$n) i <- marks(V[...]) # extract corresponding subsets of vectors Z <- Z[i] w <- w[i] # take subset of points, using any type of subset index U <- U[...] # stick together quad(U[Z], U[!Z], w) } domain.quad <- Window.quad <- function(X, ...) { as.owin(X) } "Window<-.quad" <- function(X, ..., value) { verifyclass(value, "owin") return(X[value]) } unitname.quad <- function(x) { return(unitname(x$data)) } "unitname<-.quad" <- function(x, value) { unitname(x$data) <- value unitname(x$dummy) <- value return(x) } spatstat.geom/R/owin2mask.R0000644000176200001440000000370014611065352015304 0ustar liggesusers#' #' owin2mask.R #' #' Mask approximations which are guaranteed to be entirely inside #' or entirely covering the original window. #' #' $Revision: 1.8 $ $Date: 2023/05/04 00:58:17 $ #' owin2mask <- function(W, op=c("sample", "notsample", "cover", "inside", "uncover", "outside", "boundary", "majority", "minority"), ...) { op <- match.arg(op) if(is.mask(W) && (length(list(...)) == 0)) { ## W is already a mask and there is no change to the raster switch(op, sample = , cover = , majority = , inside = { return(W) }, notsample = , uncover = , minority = , outside = { return(complement.owin(W)) }, boundary = { M <- W }) } else { ## convert to mask M <- as.mask(W, ...) } ## (M consists of all pixels whose centres are inside W) ## Do more processing switch(op, sample = , notsample = { ## nothing }, inside = , outside = , cover = , uncover = , boundary = { ## convert the boundary to a mask P <- as.polygonal(W) B <- psp2mask(edges(P), xy=M) }, majority = , minority = { ## compute the fraction of occupied area in each pixel U <- pixellate(W, M, DivideByPixelArea=TRUE) }) ## Finally determine the mask R <- switch(op, sample = M, notsample = complement.owin(M), inside = setminus.owin(M, B), outside = setminus.owin(complement.owin(M), B), cover = union.owin(M, B), uncover = union.owin(complement.owin(M), B), boundary = B, majority = levelset(U, 0.5, ">="), minority = levelset(U, 0.5, "<")) return(R) } spatstat.geom/R/dist2dpath.R0000644000176200001440000000415714611065351015446 0ustar liggesusers# # dist2dpath.R # # $Revision: 1.12 $ $Date: 2022/05/21 09:52:11 $ # # dist2dpath compute shortest path distances # dist2dpath <- function(dist, method="C") { ## given a matrix of distances between adjacent vertices ## (value = Inf if not adjacent) ## compute the matrix of shortest path distances stopifnot(is.matrix(dist) && isSymmetric(dist)) stopifnot(all(diag(dist) == 0)) findist <- dist[is.finite(dist)] if(any(findist < 0)) stop("Some distances are negative") ## n <- nrow(dist) if(n <= 1L) return(dist) cols <- col(dist) ## tol <- .Machine$double.eps posdist <- findist[findist > 0] if(length(posdist) > 0) { shortest <- min(posdist) tol2 <- shortest/max(n,1024) tol <- max(tol, tol2) } ## switch(method, interpreted={ dpathnew <- dpath <- dist changed <- TRUE while(changed) { for(j in 1:n) dpathnew[,j] <- apply(dpath + dist[j,][cols], 1L, min) unequal <- (dpathnew != dpath) changed <- any(unequal) & any(abs(dpathnew-dpath)[unequal] > tol) dpath <- dpathnew } }, C={ adj <- is.finite(dist) diag(adj) <- TRUE d <- dist d[!adj] <- -1 z <- .C(SG_Ddist2dpath, nv=as.integer(n), d=as.double(d), adj=as.integer(adj), dpath=as.double(numeric(n*n)), tol=as.double(tol), niter=as.integer(integer(1L)), status=as.integer(integer(1L)), PACKAGE="spatstat.geom") if(z$status == -1L) warning(paste("C algorithm did not converge to tolerance", tol, "after", z$niter, "iterations", "on", n, "vertices and", sum(adj) - n, "edges")) dpath <- matrix(z$dpath, n, n) ## value=-1 implies unreachable dpath[dpath < 0] <- Inf }, stop(paste("Unrecognised method", sQuote(method)))) return(dpath) } spatstat.geom/R/cut.ppp.R0000644000176200001440000000243214611065351014763 0ustar liggesusers# # cut.ppp.R # # cut method for ppp objects # # $Revision: 1.16 $ $Date: 2022/01/04 05:30:06 $ # cut.ppp <- function(x, z=marks(x), ...) { x <- as.ppp(x) if(missing(z) || is.null(z)) { z <- marks(x, dfok=TRUE) if(is.null(z)) stop("x has no marks to cut") } if(is.character(z)) { if(length(z) == npoints(x)) { # interpret as a factor z <- factor(z) } else if((length(z) == 1L) && (z %in% colnames(df <- as.data.frame(x)))) { # interpret as the name of a column of marks or coordinates z <- df[, z] } else stop("format of argument z not understood") } if(is.factor(z) || is.vector(z)) { stopifnot(length(z) == npoints(x)) g <- if(is.factor(z)) z else if(is.numeric(z)) cut(z, ...) else factor(z) marks(x) <- g return(x) } if(is.data.frame(z) || is.matrix(z)) { stopifnot(nrow(z) == npoints(x)) # take first column z <- z[,1L] g <- if(is.numeric(z)) cut(z, ...) else factor(z) marks(x) <- g return(x) } if(is.im(z)) return(cut(x, z[x, drop=FALSE], ...)) if(is.owin(z)) { marks(x) <- factor(inside.owin(x$x, x$y, z), levels=c(FALSE, TRUE)) return(x) } if(is.tess(z)) { marks(x) <- tileindex(x$x, x$y, z) return(x) } stop("Format of z not understood") } spatstat.geom/R/nncross.R0000644000176200001440000002007214611065352015060 0ustar liggesusers# # nncross.R # # # $Revision: 1.43 $ $Date: 2024/02/02 02:37:06 $ # # Copyright (C) Adrian Baddeley, Jens Oehlschlaegel and Rolf Turner 2000-2012 # Licence: GNU Public Licence >= 2 nncross <- function(X, Y, ...) { UseMethod("nncross") } nncross.default <- function(X, Y, ...) { X <- as.ppp(X, W=boundingbox) nncross(X, Y, ...) } nncross.ppp <- function(X, Y, iX=NULL, iY=NULL, what = c("dist", "which"), ..., k = 1, sortby=c("range", "var", "x", "y"), is.sorted.X = FALSE, is.sorted.Y = FALSE, metric=NULL) { stopifnot(is.ppp(Y) || is.psp(Y)) if(!is.null(metric)) { ans <- invoke.metric(metric, "nncross.ppp", X=X, Y=Y, iX=iX, iY=iY, what=what, ..., k=k, sortby=sortby, is.sorted.X=is.sorted.X, is.sorted.Y=is.sorted.Y) return(ans) } sortby <- match.arg(sortby) what <- match.arg(what, choices=c("dist", "which"), several.ok=TRUE) want.dist <- "dist" %in% what want.which <- "which" %in% what want.both <- want.dist && want.which if(!missing(k)) { # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } } k <- as.integer(k) kmax <- max(k) nk <- length(k) nX <- npoints(X) nY <- nobjects(Y) ## trivial cases if(nX == 0 || nY == 0) { result <- list(dist=matrix(Inf, nrow=nX, ncol=nk), which=matrix(NA_integer_, nrow=nX, ncol=nk))[what] result <- as.data.frame(result) if(ncol(result) == 1) result <- result[, , drop=TRUE] return(result) } ## Y is a line segment pattern if(is.psp(Y)) { if(identical(k, 1L)) return(ppllengine(X,Y,"distance")[, what]) ## all distances D <- distppll(coords(X), Y$ends, mintype=0) ans <- XDtoNN(D, what=what, iX=iX, iY=iX, k=k) return(ans) } # Y is a point pattern if(is.null(iX) != is.null(iY)) stop("If one of iX, iY is given, then both must be given") exclude <- (!is.null(iX) || !is.null(iY)) if(exclude) { stopifnot(is.integer(iX) && is.integer(iY)) if(length(iX) != nX) stop("length of iX does not match the number of points in X") if(length(iY) != nY) stop("length of iY does not match the number of points in Y") } if((is.sorted.X || is.sorted.Y) && !(sortby %in% c("x", "y"))) stop(paste("If data are already sorted,", "the sorting coordinate must be specified explicitly", "using sortby = \"x\" or \"y\"")) # decide whether to sort on x or y coordinate switch(sortby, range = { WY <- as.owin(Y) sortby.y <- (diff(WY$xrange) < diff(WY$yrange)) }, var = { sortby.y <- (var(Y$x) < var(Y$y)) }, x={ sortby.y <- FALSE}, y={ sortby.y <- TRUE} ) # The C code expects points to be sorted by y coordinate. if(sortby.y) { Xx <- X$x Xy <- X$y Yx <- Y$x Yy <- Y$y } else { Xx <- X$y Xy <- X$x Yx <- Y$y Yy <- Y$x } # sort only if needed if(!is.sorted.X){ oX <- fave.order(Xy) Xx <- Xx[oX] Xy <- Xy[oX] if(exclude) iX <- iX[oX] } if (!is.sorted.Y){ oY <- fave.order(Yy) Yx <- Yx[oY] Yy <- Yy[oY] if(exclude) iY <- iY[oY] } #' Largest possible distance computable in double precision huge <- sqrt(.Machine$double.xmax) #' Code initialises nndist^2 to huge^2 #' and returns nndist='huge' whenever the set of distances is empty huge <- 0.999 * huge # Ensures huge^2 <= .Machine$double.xmax # number of neighbours that are well-defined kmaxcalc <- min(nY, kmax) if(kmaxcalc == 1) { # ............... single nearest neighbour .................. # call C code nndv <- if(want.dist) numeric(nX) else numeric(1) nnwh <- if(want.which) integer(nX) else integer(1) if(!exclude) iX <- iY <- integer(1) z <- .C(SG_nnXinterface, n1=as.integer(nX), x1=as.double(Xx), y1=as.double(Xy), id1=as.integer(iX), n2=as.integer(nY), x2=as.double(Yx), y2=as.double(Yy), id2=as.integer(iY), exclude = as.integer(exclude), wantdist = as.integer(want.dist), wantwhich = as.integer(want.which), nnd=as.double(nndv), nnwhich=as.integer(nnwh), huge=as.double(huge), PACKAGE="spatstat.geom") if(want.which) nnwcode <- z$nnwhich #sic. C code now increments by 1 if(want.dist) nndval <- z$nnd if(want.which && any(uhoh <- (nnwcode == 0))) { if(!exclude) warning("NA's unexpectedly produced in nncross()$which", call.=FALSE) nnwcode[uhoh] <- NA if(want.dist) nndval[uhoh] <- Inf } else if(want.dist && any(uhoh <- (nndval > 0.99 * huge))) { if(!exclude) warning("Infinite distances unexpectedly returned in nncross", call.=FALSE) nndval[uhoh] <- Inf } # reinterpret in original ordering if(is.sorted.X){ if(want.dist) nndv <- nndval if(want.which) nnwh <- if(is.sorted.Y) nnwcode else oY[nnwcode] } else { if(want.dist) nndv[oX] <- nndval if(want.which) nnwh[oX] <- if(is.sorted.Y) nnwcode else oY[nnwcode] } if(want.both) return(data.frame(dist=nndv, which=nnwh)) return(if(want.dist) nndv else nnwh) } else { # ............... k nearest neighbours .................. # call C code nndv <- if(want.dist) numeric(nX * kmaxcalc) else numeric(1) nnwh <- if(want.which) integer(nX * kmaxcalc) else integer(1) if(!exclude) iX <- iY <- integer(1) z <- .C(SG_knnXinterface, n1=as.integer(nX), x1=as.double(Xx), y1=as.double(Xy), id1=as.integer(iX), n2=as.integer(nY), x2=as.double(Yx), y2=as.double(Yy), id2=as.integer(iY), kmax=as.integer(kmaxcalc), exclude = as.integer(exclude), wantdist = as.integer(want.dist), wantwhich = as.integer(want.which), nnd=as.double(nndv), nnwhich=as.integer(nnwh), huge=as.double(huge), PACKAGE="spatstat.geom") # extract results nnD <- z$nnd nnW <- z$nnwhich # map 0 to NA if(want.which && any(uhoh <- (nnW == 0))) { nnW[uhoh] <- NA if(want.dist) nnD[uhoh] <- Inf } else if(want.dist && any(uhoh <- (nnD > 0.99 * huge))) nnD[uhoh] <- Inf # reinterpret indices in original ordering if(!is.sorted.Y) nnW <- oY[nnW] # reform as matrices NND <- if(want.dist) matrix(nnD, nrow=nX, ncol=kmaxcalc, byrow=TRUE) else 0 NNW <- if(want.which) matrix(nnW, nrow=nX, ncol=kmaxcalc, byrow=TRUE) else 0 if(!is.sorted.X){ # rearrange rows to correspond to original ordering of points if(want.dist) NND[oX, ] <- NND if(want.which) NNW[oX, ] <- NNW } # the return value should correspond to the original vector k if(kmax > kmaxcalc) { # add columns of NA / Inf kextra <- kmax - kmaxcalc if(want.dist) NND <- cbind(NND, matrix(Inf, nrow=nX, ncol=kextra)) if(want.which) NNW <- cbind(NNW, matrix(NA_integer_, nrow=nX, ncol=kextra)) } if(length(k) < kmax) { # select only the specified columns if(want.dist) NND <- NND[, k, drop=TRUE] if(want.which) NNW <- NNW[, k, drop=TRUE] } result <- as.data.frame(list(dist=NND, which=NNW)[what]) colnames(result) <- c(if(want.dist) paste0("dist.", k) else NULL, if(want.which) paste0("which.",k) else NULL) if(ncol(result) == 1) result <- result[, , drop=TRUE] return(result) } } spatstat.geom/R/split.ppp.R0000644000176200001440000002434714735370477015353 0ustar liggesusers# # split.ppp.R # # $Revision: 1.42 $ $Date: 2024/12/03 02:09:40 $ # # split.ppp and "split<-.ppp" # ######################################### split.ppp <- function(x, f = marks(x), drop=FALSE, un=NULL, reduce=FALSE, ...) { verifyclass(x, "ppp") mf <- markformat(x) fgiven <- !missing(f) if(is.null(un)) { un <- !fgiven && (mf != "dataframe") } else un <- as.logical(un) if(!fgiven) { # f defaults to marks of x switch(mf, none={ stop("f is missing and there are no marks") }, vector={ if(!is.multitype(x)) stop("f is missing and the pattern is not multitype") f <- fsplit <- marks(x) }, dataframe={ f <- fsplit <- firstfactor(marks(x)) if(is.null(f)) stop("Data frame of marks contains no factors") }) splittype <- "factor" } else { # f was given fsplit <- f if(is.factor(f)) { splittype <- "factor" } else if(is.logical(f)) { splittype <- "factor" f <- factor(f) } else if(is.tess(f)) { # f is a tessellation: determine the grouping f <- marks(cut(x, fsplit)) splittype <- "tess" } else if(is.owin(f)) { # f is a window: coerce to a tessellation W <- as.owin(x) fsplit <- tess(tiles=list(fsplit, setminus.owin(W, fsplit)), window=W) f <- marks(cut(x, fsplit)) splittype <- "tess" } else if(is.im(f)) { # f is an image: coerce to a tessellation fsplit <- tess(image=f) f <- marks(cut(x, fsplit)) splittype <- "tess" } else if(is.character(f) && length(f) == 1) { # f should be 'marks' or the name of a column of marks marx <- marks(x) switch(markformat(x), none = { stop(paste("The name", sQuote(f), "does not specify a column of marks", "(there are no marks)"), call.=FALSE) }, vector = { if(f != "marks") stop(paste("The name", sQuote(f), "does not specify a column of marks", "(the marks are a vector)"), call.=FALSE) fsplit <- f <- as.factor(marx) }, dataframe = , hyperframe = { if(!(f %in% colnames(marx))) stop(paste("The name", sQuote(f), "does not match any column of marks"), call.=FALSE) fsplit <- f <- as.factor(marx[,f, drop=TRUE]) }, stop(paste("The name", sQuote(f), "is not recognised as a column of marks"), call.=FALSE) ) splittype <- "factor" } else stop(paste("f must be", "a factor, a logical vector,", "a tessellation, a window, an image,", "or the name of a column of marks")) if(length(f) != npoints(x)) stop("length(f) must equal the number of points in x") } # At this point # 'f' is a factor that can be used to separate the points # 'fsplit' is the object (either a factor or a tessellation) # that determines the split (and can be "un-split") lev <- levels(f) if(drop) { # remove components that don't contain points retain <- (table(f) > 0) lev <- lev[retain] switch(splittype, tess = { # remove tiles that don't contain points fsplit <- fsplit[retain] }, factor = { # delete levels that don't occur fsplit <- factor(fsplit, levels=lev) }, stop("Internal error: wrong format for fsplit")) } ## remove marks that will not be retained if(un && reduce && mf == "dataframe") warning("Incompatible arguments un=TRUE and reduce=TRUE: assumed un=TRUE") if(un) { x <- unmark(x) } else if(reduce && !fgiven && mf == "dataframe") { # remove the column of marks that determined the split j <- findfirstfactor(marks(x)) if(!is.null(j)) marks(x) <- marks(x)[, -j] } ## split the data out <- list() fok <- !is.na(f) for(l in lev) out[[paste(l)]] <- x[fok & (f == l)] ## if(splittype == "tess") { til <- tiles(fsplit) for(i in seq_along(out)) out[[i]]$window <- til[[i]] } class(out) <- c("splitppp", "ppplist", "solist", class(out)) attr(out, "fsplit") <- fsplit attr(out, "fgroup") <- f return(out) } "split<-.ppp" <- function(x, f=marks(x), drop=FALSE, un=NULL, ..., value) { verifyclass(x, "ppp") W <- x$window fgiven <- !missing(f) mf <- markformat(x) # evaluate `un' before assigning value of 'f' if(is.null(un)) { un <- !fgiven && (mf != "dataframe") } else un <- as.logical(un) # validate assignment value stopifnot(is.list(value)) if(!all(unlist(lapply(value, is.ppp)))) stop(paste("Each entry of", sQuote("value"), "must be a point pattern")) ismark <- unlist(lapply(value, is.marked)) if(any(ismark) && !all(ismark)) stop(paste("Some entries of", sQuote("value"), "are marked, and others are unmarked")) vmarked <- all(ismark) # determine type of splitting if(missing(f)) { # f defaults to marks of x switch(mf, none={ stop("f is missing and there are no marks") }, vector={ if(!is.multitype(x)) stop("f is missing and the pattern is not multitype") f <- fsplit <- marks(x) }, dataframe={ f <- fsplit <- firstfactor(marks(x)) if(is.null(f)) stop("Data frame of marks contains no factors") }) } else { # f given fsplit <- f if(is.tess(f)) { # f is a tessellation: determine the grouping f <- marks(cut(x, fsplit)) } else if(is.im(f)) { # f is an image: determine the grouping fsplit <- tess(image=f) f <- marks(cut(x, fsplit)) } else if(is.character(f) && length(f) == 1) { # f is the name of a column of marks marx <- marks(x) if(is.data.frame(marx) && (f %in% names(marx))) fsplit <- f <- marx[[f]] else stop(paste("The name", sQuote(f), "does not match any column of marks")) } else if(is.logical(f)) { f <- factor(f) } else if(!is.factor(f)) stop(paste("f must be", "a factor, a logical vector, a tessellation, an image,", "or the name of a column of marks")) if(length(f) != x$n) stop("length(f) must equal the number of points in x") } # all.levels <- lev <- levels(f) if(!drop) levtype <- "levels of f" else { levtype <- "levels which f actually takes" # remove components that don't contain points lev <- lev[table(f) > 0] } if(length(value) != length(lev)) stop(paste("length of", sQuote("value"), "should equal the number of", levtype)) # ensure value[[i]] is associated with lev[i] if(!is.null(names(value))) { if(!all(names(value) %in% as.character(lev))) stop(paste("names of", sQuote("value"), "should be levels of f")) value <- value[lev] } names(value) <- NULL # restore the marks, if they were discarded if(un && is.marked(x)) { if(vmarked) warning(paste(sQuote("value"), "contains marked point patterns:", "this is inconsistent with un=TRUE; marks ignored.")) for(i in seq_along(value)) value[[i]] <- value[[i]] %mark% factor(lev[i], levels=all.levels) } # handle NA's in splitting factor if(any(isNA <- is.na(f))) { xNA <- x[isNA] if(un && is.marked(x)) xNA <- xNA %mark% factor(NA, levels=all.levels) value <- append(value, list(xNA)) } # put Humpty together again if(npoints(x) == length(f) && length(levels(f)) == length(value) && all(table(f) == sapply(value, npoints))) { ## exact correspondence out <- x for(i in seq_along(levels(f))) out[ f == lev[i] ] <- value[[i]] } else { out <- do.call(superimpose,c(value,list(W=W))) } return(out) } print.splitppp <- function(x, ...) { f <- attr(x, "fsplit") what <- if(is.tess(f)) "tessellation" else if(is.factor(f)) "factor" else if(is.logical(f)) "logical vector" else typeof(f) cat(paste("Point pattern split by", what, "\n")) nam <- names(x) for(i in seq_along(x)) { cat(paste("\n", nam[i], ":\n", sep="")) print(x[[i]]) } return(invisible(NULL)) } summary.splitppp <- function(object, ...) { x <- lapply(object, summary, ...) class(x) <- "summary.splitppp" x } print.summary.splitppp <- function(x, ...) { class(x) <- "anylist" print(x) invisible(NULL) } "[.splitppp" <- function(x, ...) { f <- attr(x, "fsplit") # invoke list method on x class(x) <- "list" y <- x[...] # then make it a 'splitppp' object too class(y) <- c("splitppp", class(y)) if(is.tess(f)) { fsplit <- f[...] } else if(is.factor(f)) { lev <- levels(f) sublev <- lev[...] subf <- f[f %in% sublev] fsplit <- factor(subf, levels=lev) } else stop("Unknown splitting type") attr(y, "fsplit") <- fsplit y } "[<-.splitppp" <- function(x, ..., value) { if(!all(unlist(lapply(value, is.ppp)))) stop("replacement value must be a list of point patterns") f <- attr(x, "fsplit") # invoke list method class(x) <- "list" x[...] <- value # then make it a 'splitppp' object too class(x) <- c("splitppp", class(x)) if(is.tess(f)) { fsplit <- f } else if(is.factor(f)) { lev <- levels(f) fsplit <- factor(rep.int(lev, unlist(lapply(x, npoints))), levels=lev) } attr(x, "fsplit") <- fsplit x } plot.splitppp <- local({ plot.splitppp <- function(x, ..., main) { if(missing(main)) main <- short.deparse(substitute(x)) plsplp(x, ..., main=main) } plsplp <- function(x, ..., main, plotcommand="plot", equal.scales) { if(missing(equal.scales)) equal.scales <- plotcommand %in% c("plot", "image") plot.solist(x, ..., main=main, plotcommand=plotcommand, equal.scales=equal.scales) } plot.splitppp }) as.layered.splitppp <- function(X) { do.call(layered, X) } spatstat.geom/R/Math.im.R0000644000176200001440000000237714611065351014677 0ustar liggesusers## ## Math.im.R ## ## $Revision: 1.9 $ $Date: 2020/10/31 05:06:15 $ ## Math.im <- function(x, ...){ m <- do.call(.Generic, list(x$v, ...)) rslt <- im(m, xcol = x$xcol, yrow = x$yrow, xrange = x$xrange, yrange = x$yrange, unitname = unitname(x)) return(rslt) } Summary.im <- function(..., na.rm=FALSE, drop=TRUE){ argh <- list(...) ims <- sapply(argh, is.im) argh[ims] <- lapply(argh[ims], getElement, name="v") do.call(.Generic, c(argh, list(na.rm = na.rm || drop))) } Complex.im <- function(z){ m <- do.call(.Generic, list(z=z$v)) rslt <- im(m, xcol = z$xcol, yrow = z$yrow, xrange = z$xrange, yrange = z$yrange, unitname = unitname(z)) return(rslt) } ## The following function defines what happens in 'Ops.im' ## but the formal 'Ops.im' method is now in Math.imlist.R imageOp <- function(e1, e2=NULL, op) { ## operate on an image or pair of images if(is.null(e2)) { ## unary operation if(!is.element(op, c("!", "-", "+"))) stop(paste("Unary operation", sQuote(op), "is undefined for images"), call.=FALSE) expr <- parse(text = paste(op, "e1")) } else { expr <- parse(text = paste("e1", op, "e2")) } return(do.call(eval.im, list(expr = expr))) } spatstat.geom/R/headtail.R0000644000176200001440000000103514611065352015144 0ustar liggesusers#' #' headtail.R #' #' Methods for head() and tail() #' #' $Revision: 1.2 $ $Date: 2022/01/04 05:30:06 $ head.tess <- head.psp <- head.ppx <- head.ppp <- function(x, n=6L, ...) { stopifnot(length(n) == 1L) xlen <- nobjects(x) n <- if (n < 0L) max(xlen + n, 0L) else min(n, xlen) x[seq_len(n)] } tail.tess <- tail.psp <- tail.ppx <- tail.ppp <- function (x, n = 6L, ...) { stopifnot(length(n) == 1L) xlen <- nobjects(x) n <- if (n < 0L) max(xlen + n, 0L) else min(n, xlen) x[seq.int(to = xlen, length.out = n)] } spatstat.geom/R/nndist.R0000644000176200001440000002664314611065352014704 0ustar liggesusers# # nndist.R # # nearest neighbour distances (nndist) and identifiers (nnwhich) # # $Revision: 1.17 $ $Date: 2022/05/21 09:52:11 $ # nndist <- function(X, ...) { UseMethod("nndist") } nndist.ppp <- local({ nndist.ppp <- function(X, ..., k=1, by=NULL, method="C", metric=NULL) { verifyclass(X, "ppp") trap.extra.arguments(..., .Context="In nndist.ppp") if(!is.null(metric)) { d <- invoke.metric(metric, "nndist.ppp", X, ..., k=k, by=by, method=method) return(d) } if(is.null(by)) # usual case return(nndist.default(X$x, X$y, k=k, by=by, method=method)) return(nndistby(X, k=k, by=by)) } nndistby <- function(X, k, by) { ## split by factor if(is.character(by)) { ## Interpret using split.ppp Y <- split(X, f=by, drop=FALSE) by <- attr(Y, "fgroup") } idX <- seq_len(npoints(X)) Y <- split(X %mark% idX, f=by, un=FALSE) distY <- lapply(Y, nndistsub, XX=X, iX=idX, k=k) result <- do.call(cbind, distY) return(result) } nndistsub <- function(Z, XX, iX, k) { nncross(XX, Z, iX=iX, iY=marks(Z), k=k, what="dist") } nndist.ppp }) nndist.default <- function(X, Y=NULL, ..., k=1, by=NULL, method="C") { warn.no.metric.support("nndist.default", ...) # computes the vector of nearest-neighbour distances # for the pattern of points (x[i],y[i]) # xy <- xy.coords(X,Y)[c("x","y")] x <- xy$x y <- xy$y # validate n <- length(x) if(length(y) != n) stop("lengths of x and y do not match") method <- match.arg(method, c("C", "interpreted", "test")) # other arguments ignored trap.extra.arguments(..., .Context="In nndist.default") # split by factor ? if(!is.null(by)) { X <- as.ppp(xy, W=boundingbox) return(nndist(X, by=by, k=k)) } # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } k <- as.integer(k) kmax <- max(k) # trivial cases if(n <= 1) { # empty pattern => return numeric(0) # or pattern with only 1 point => return Inf nnd <- matrix(Inf, nrow=n, ncol=kmax) nnd <- nnd[,k, drop=TRUE] return(nnd) } # number of neighbours that are well-defined kmaxcalc <- min(n-1, kmax) # calculate k-nn distances for k <= kmaxcalc if(kmaxcalc == 1) { # calculate nearest neighbour distance only switch(method, test = , interpreted={ # matrix of squared distances between all pairs of points sq <- function(a, b) { (a-b)^2 } squd <- outer(x, x, sq) + outer(y, y, sq) # reset diagonal to a large value so it is excluded from minimum diag(squd) <- Inf # nearest neighbour distances nnd <- sqrt(apply(squd,1,min)) }, C={ nnd<-numeric(n) o <- fave.order(y) big <- sqrt(.Machine$double.xmax) z <- .C(SG_nndistsort, n= as.integer(n), x= as.double(x[o]), y= as.double(y[o]), nnd= as.double(nnd), as.double(big), PACKAGE="spatstat.geom") nnd[o] <- z$nnd }, stop(paste("Unrecognised method", sQuote(method))) ) } else { # case kmaxcalc > 1 switch(method, test = , interpreted={ if(n <= 1000 && method == "interpreted") { # form n x n matrix of squared distances D2 <- pairdist.default(x, y, method=method, squared=TRUE) # find k'th smallest squared distance diag(D2) <- Inf NND2 <- t(apply(D2, 1, sort))[, 1:kmaxcalc] nnd <- sqrt(NND2) } else { # avoid creating huge matrix # handle one row of D at a time NND2 <- matrix(numeric(n * kmaxcalc), nrow=n, ncol=kmaxcalc) for(i in seq_len(n)) { D2i <- (x - x[i])^2 + (y - y[i])^2 D2i[i] <- Inf NND2[i,] <- orderstats(D2i, k=1:kmaxcalc) } nnd <- sqrt(NND2) } }, C={ nnd<-numeric(n * kmaxcalc) o <- fave.order(y) big <- sqrt(.Machine$double.xmax) z <- .C(SG_knndsort, n = as.integer(n), kmax = as.integer(kmaxcalc), x = as.double(x[o]), y = as.double(y[o]), nnd = as.double(nnd), huge = as.double(big), PACKAGE="spatstat.geom") nnd <- matrix(nnd, nrow=n, ncol=kmaxcalc) nnd[o, ] <- matrix(z$nnd, nrow=n, ncol=kmaxcalc, byrow=TRUE) }, stop(paste("Unrecognised method", sQuote(method))) ) } # post-processing if(kmax > kmaxcalc) { # add columns of Inf infs <- matrix(Inf, nrow=n, ncol=kmax-kmaxcalc) nnd <- cbind(nnd, infs) } if(kmax > 1) colnames(nnd) <- paste0("dist.", 1:kmax) if(length(k) < kmax) { # select only the specified columns nnd <- nnd[, k, drop=TRUE] } return(nnd) } nnwhich <- function(X, ...) { UseMethod("nnwhich") } nnwhich.ppp <- local({ nnwhich.ppp <- function(X, ..., k=1, by=NULL, method="C", metric=NULL) { verifyclass(X, "ppp") trap.extra.arguments(..., .Context="In nnwhich.ppp") if(!is.null(metric)) { d <- invoke.metric(metric, "nnwhich.ppp", X, ..., k=k, by=by, method=method) return(d) } if(is.null(by)) return(nnwhich.default(X$x, X$y, k=k, method=method)) return(nnwhichby(X, k=k, by=by)) } nnwhichby <- function(X, k, by) { # split by factor if(is.character(by)) { ## Interpret using split.ppp Y <- split(X, f=by, drop=FALSE) by <- attr(Y, "fgroup") } idX <- seq_len(npoints(X)) Y <- split(X %mark% idX, f=by, un=FALSE) whichY <- lapply(Y, nnwhichsub, XX=X, iX=idX, k=k) result <- do.call(cbind, whichY) return(result) } nnwhichsub <- function(Z, XX, iX, k) { # marks(Z) gives original serial numbers of subset Z iY <- marks(Z) Zid <- nncross(XX, Z, iX=iX, iY=iY, k=k, what="which") nk <- length(k) if(nk == 1) { Yid <- iY[Zid] } else { Zid <- as.vector(as.matrix(Zid)) Yid <- iY[Zid] Yid <- data.frame(which=matrix(Yid, ncol=nk)) } return(Yid) } nnwhich.ppp }) nnwhich.default <- function(X, Y=NULL, ..., k=1, by=NULL, method="C") { warn.no.metric.support("nnwhich.default", ...) # identifies nearest neighbour of each point in # the pattern of points (x[i],y[i]) # xy <- xy.coords(X,Y)[c("x","y")] x <- xy$x y <- xy$y # validate n <- length(x) if(length(y) != n) stop("lengths of x and y do not match") method <- match.arg(method, c("C", "interpreted", "test")) # other arguments ignored trap.extra.arguments(..., .Context="In nnwhich.default") # split by factor ? if(!is.null(by)) { X <- as.ppp(xy, W=boundingbox) return(nnwhich(X, by=by, k=k)) } # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } k <- as.integer(k) kmax <- max(k) # special cases if(n <= 1) { # empty pattern => return integer(0) # or pattern with only 1 point => return NA nnw <- matrix(as.integer(NA), nrow=n, ncol=kmax) nnw <- nnw[,k, drop=TRUE] return(nnw) } # number of neighbours that are well-defined kmaxcalc <- min(n-1, kmax) # identify k-nn for k <= kmaxcalc if(kmaxcalc == 1) { # identify nearest neighbour only switch(method, test = , interpreted={ # matrix of squared distances between all pairs of points sq <- function(a, b) { (a-b)^2 } squd <- outer(x, x, sq) + outer(y, y, sq) # reset diagonal to a large value so it is excluded from minimum diag(squd) <- Inf # nearest neighbours nnw <- apply(squd,1,which.min) }, C={ nnw <- integer(n) o <- fave.order(y) big <- sqrt(.Machine$double.xmax) z <- .C(SG_nnwhichsort, n = as.integer(n), x = as.double(x[o]), y = as.double(y[o]), nnwhich = as.integer(nnw), huge = as.double(big), PACKAGE="spatstat.geom") witch <- z$nnwhich # sic if(any(witch <= 0)) stop("Internal error: non-positive index returned from C code") if(any(witch > n)) stop("Internal error: index returned from C code exceeds n") nnw[o] <- o[witch] }, stop(paste("Unrecognised method", sQuote(method))) ) } else { # case kmaxcalc > 1 switch(method, test = , interpreted={ if(n <= 1000 && method == "interpreted") { # form n x n matrix of squared distances D2 <- pairdist.default(x, y, method=method, squared=TRUE) # find k'th smallest squared distance diag(D2) <- Inf nnw <- t(apply(D2, 1, fave.order))[, 1:kmaxcalc] } else { # avoid creating huge matrix # handle one row of D at a time nnw <- matrix(as.integer(NA), nrow=n, ncol=kmaxcalc) for(i in seq_len(n)) { D2i <- (x - x[i])^2 + (y - y[i])^2 D2i[i] <- Inf nnw[i,] <- fave.order(D2i)[1:kmaxcalc] } } }, C={ nnw <- matrix(integer(n * kmaxcalc), nrow=n, ncol=kmaxcalc) o <- fave.order(y) big <- sqrt(.Machine$double.xmax) z <- .C(SG_knnwhich, n = as.integer(n), kmax = as.integer(kmaxcalc), x = as.double(x[o]), y = as.double(y[o]), nnwhich = as.integer(nnw), huge = as.double(big), PACKAGE="spatstat.geom") witch <- z$nnwhich # sic witch <- matrix(witch, nrow=n, ncol=kmaxcalc, byrow=TRUE) if(any(witch <= 0)) stop("Internal error: non-positive index returned from C code") if(any(witch > n)) stop("Internal error: index returned from C code exceeds n") # convert back to original ordering nnw[o,] <- matrix(o[witch], nrow=n, ncol=kmaxcalc) }, stop(paste("Unrecognised method", sQuote(method))) ) } # post-processing if(kmax > kmaxcalc) { # add columns of NA's nas <- matrix(as.numeric(NA), nrow=n, ncol=kmax-kmaxcalc) nnw <- cbind(nnw, nas) } if(kmax > 1) colnames(nnw) <- paste0("which.", 1:kmax) if(length(k) < kmax) { # select only the specified columns nnw <- nnw[, k, drop=TRUE] } return(nnw) } spatstat.geom/R/nnmap.R0000644000176200001440000001456514611065352014516 0ustar liggesusers# # nnmap.R # # nearest or k-th nearest neighbour of each pixel # # $Revision: 1.13 $ $Date: 2022/05/21 09:52:11 $ # nnmap <- function(X, k=1, what = c("dist", "which"), ..., W=as.owin(X), is.sorted.X=FALSE, sortby=c("range", "var", "x", "y")) { stopifnot(is.ppp(X)) sortby <- match.arg(sortby) outputarray <- resolve.1.default("outputarray", ..., outputarray=FALSE) W <- as.owin(W %orifnull% X) huge <- 1.1 * diameter(boundingbox(as.rectangle(X), as.rectangle(W))) what <- match.arg(what, choices=c("dist", "which"), several.ok=TRUE) want.dist <- "dist" %in% what want.which <- "which" %in% what want.both <- want.dist && want.which if(!missing(k)) { # k can be a single integer or an integer vector if(length(k) == 0) stop("k is an empty vector") else if(length(k) == 1) { if(k != round(k) || k <= 0) stop("k is not a positive integer") } else { if(any(k != round(k)) || any(k <= 0)) stop(paste("some entries of the vector", sQuote("k"), "are not positive integers")) } } k <- as.integer(k) kmax <- max(k) nk <- length(k) # note whether W is `really' a rectangle isrect <- is.rectangle(rescue.rectangle(W)) # set up pixel array M <- do.call.matched(as.mask, resolve.defaults(list(...), list(w=quote(W)))) Mdim <- M$dim nxcol <- Mdim[2] nyrow <- Mdim[1] npixel <- nxcol * nyrow nX <- npoints(X) if(nX == 0) { # trivial - avoid potential problems in C code NND <- if(want.dist) array(Inf, dim=c(nk, Mdim)) else 0 NNW <- if(want.which) array(NA_integer_, dim=c(nk, Mdim)) else 0 } else { # usual case if(is.sorted.X && !(sortby %in% c("x", "y"))) stop(paste("If data are already sorted,", "the sorting coordinate must be specified explicitly", "using sortby = \"x\" or \"y\"")) # decide whether to sort on x or y coordinate switch(sortby, range = { s <- sidelengths(as.rectangle(X)) sortby.y <- (s[1] < s[2]) }, var = { sortby.y <- (var(X$x) < var(X$y)) }, x={ sortby.y <- FALSE}, y={ sortby.y <- TRUE} ) # The C code expects points to be sorted by x coordinate. if(sortby.y) { oldM <- M X <- flipxy(X) W <- flipxy(W) M <- flipxy(M) Mdim <- M$dim nxcol <- Mdim[2] nyrow <- Mdim[1] } xx <- X$x yy <- X$y # sort only if needed if(!is.sorted.X){ oX <- fave.order(xx) xx <- xx[oX] yy <- yy[oX] } # number of neighbours that are well-defined kmaxcalc <- min(nX, kmax) # prepare to call C code nndv <- if(want.dist) numeric(npixel * kmaxcalc) else numeric(1) nnwh <- if(want.which) integer(npixel * kmaxcalc) else integer(1) # ............. call C code ............................ if(kmaxcalc == 1) { zz <- .C(SG_nnGinterface, nx = as.integer(nxcol), x0 = as.double(M$xcol[1]), xstep = as.double(M$xstep), ny = as.integer(nyrow), y0 = as.double(M$yrow[1]), ystep = as.double(M$ystep), np = as.integer(nX), xp = as.double(xx), yp = as.double(yy), wantdist = as.integer(want.dist), wantwhich = as.integer(want.which), nnd = as.double(nndv), nnwhich = as.integer(nnwh), huge = as.double(huge), PACKAGE="spatstat.geom") } else { zz <- .C(SG_knnGinterface, nx = as.integer(nxcol), x0 = as.double(M$xcol[1]), xstep = as.double(M$xstep), ny = as.integer(nyrow), y0 = as.double(M$yrow[1]), ystep = as.double(M$ystep), np = as.integer(nX), xp = as.double(xx), yp = as.double(yy), kmax = as.integer(kmaxcalc), wantdist = as.integer(want.dist), wantwhich = as.integer(want.which), nnd = as.double(nndv), nnwhich = as.integer(nnwh), huge = as.double(huge), PACKAGE="spatstat.geom") } # extract results nnW <- zz$nnwhich nnD <- zz$nnd # map index 0 to NA if(want.which && any(uhoh <- (nnW == 0))) { nnW[uhoh] <- NA if(want.dist) nnD[uhoh] <- Inf } # reinterpret indices in original ordering if(!is.sorted.X) nnW <- oX[nnW] # reform as arrays NND <- if(want.dist) array(nnD, dim=c(kmaxcalc, Mdim)) else 0 NNW <- if(want.which) array(nnW, dim=c(kmaxcalc, Mdim)) else 0 if(sortby.y) { # flip x and y back again if(want.dist) NND <- aperm(NND, c(1, 3, 2)) if(want.which) NNW <- aperm(NNW, c(1, 3, 2)) M <- oldM Mdim <- dim(M) } # the return value should correspond to the original vector k if(kmax > kmaxcalc) { # pad with NA / Inf if(want.dist) { NNDcalc <- NND NND <- array(Inf, dim=c(kmax, Mdim)) NND[1:kmaxcalc, , ] <- NNDcalc } if(want.which) { NNWcalc <- NNW NNW <- array(NA_integer_, dim=c(kmax, Mdim)) NNW[1:kmaxcalc, , ] <- NNWcalc } } if(length(k) < kmax) { # select only the specified planes if(want.dist) NND <- NND[k, , , drop=FALSE] if(want.which) NNW <- NNW[k, , , drop=FALSE] } } # secret backdoor if(outputarray) { # return result as an array or pair of arrays result <- if(want.both) { list(dist=NND, which=NNW) } else if(want.dist) NND else NNW attr(result, "pixarea") <- with(M, xstep * ystep) return(result) } # format result as a list of images result <- list() if(want.dist) { dlist <- list() for(i in 1:nk) { DI <- as.im(NND[i,,], M) if(!isrect) DI <- DI[M, drop=FALSE] dlist[[i]] <- DI } names(dlist) <- k result[["dist"]] <- if(nk > 1) dlist else dlist[[1]] } if(want.which) { wlist <- list() for(i in 1:nk) { WI <- as.im(NNW[i,,], M) if(!isrect) WI <- WI[M, drop=FALSE] wlist[[i]] <- WI } names(wlist) <- k result[["which"]] <- if(nk > 1) wlist else wlist[[1]] } if(!want.both) result <- result[[1]] return(result) } spatstat.geom/R/factors.R0000644000176200001440000000567214611065351015044 0ustar liggesusers#' #' factors.R #' #' Tools for manipulating factors and factor-valued things #' #' $Revision: 1.8 $ $Date: 2023/01/30 00:34:27 $ relevel.im <- function(x, ref, ...) { if(x$type != "factor") stop("Only valid for factor-valued images") x[] <- relevel(x[], ref, ...) return(x) } relevel.ppp <- relevel.ppx <- function(x, ref, ...) { stopifnot(is.multitype(x)) marks(x) <- relevel(marks(x), ref, ...) return(x) } mergeLevels <- function(.f, ...) { if(is.im(.f)) { aa <- mergeLevels(.f[], ...) .f[] <- aa return(.f) } if(is.multitype(.f)) { marks(.f) <- mergeLevels(marks(.f), ...) return(.f) } stopifnot(is.factor(.f)) map <- list(...) n <- length(map) if(n == 0) return(.f) # mapping for 'other' if(any(isnul <- (lengths(map) == 0))) { if(sum(isnul) > 1) stop("At most one argument should be NULL or character(0)") otherlevels <- setdiff(levels(.f), unlist(map)) map[[which(isnul)]] <- otherlevels } newlevels <- names(map) oldlevels <- levels(.f) mappedlevels <- unlist(map) if(sum(nzchar(newlevels)) != n) stop("Arguments must be in the form name=value") if(!all(mappedlevels %in% oldlevels)) stop("Argument values must be levels of .f") ## construct mapping fullmap <- oldlevels for(i in seq_len(n)) { relevant <- oldlevels %in% map[[i]] fullmap[relevant] <- newlevels[i] } ## apply mapping newf <- factor(fullmap[.f], levels=unique(fullmap)) return(newf) } levelsAsFactor <- function(x) { lev <- levels(x) if(is.null(lev)) return(NULL) return(factor(lev, levels=lev)) } harmoniseLevels <- function(...) { x <- list(...) n <- length(x) if(n == 0) return(x) if(n == 1) { x <- x[[1L]] if(!is.null(levels(x))) return(x) ## single factor or object } ## extract factor levels for each factor levlist <- lapply(x, levels) if(any(sapply(levlist, is.null))) stop("Some of the arguments do not have factor levels") if(length(unique(levlist)) == 1) return(x) # levels are already identical ## pool factor levels of all factors pooledlevels <- unique(unlist(levlist)) matchlist <- lapply(levlist, match, table=pooledlevels) if(anyNA(unlist(matchlist))) stop("Unable to harmonise levels") ## map each factor to the pooled levels xentries <- lapply(x, "[") oldcodelist <- lapply(xentries, as.integer) newcodelist <- mapply("[", matchlist, oldcodelist, SIMPLIFY=FALSE) newfactors <- lapply(newcodelist, factor, levels=seq_along(pooledlevels), labels=pooledlevels) ## assign results xnew <- vector(mode="list", length=n) isim <- sapply(x, is.im) if(any(flat <- !isim)) xnew[flat] <- newfactors[flat] if(any(isim)) xnew[isim] <- mapply("[<-", x=x[isim], value=newfactors[isim], SIMPLIFY=FALSE) ## format names(xnew) <- names(x) if(is.solist(x) || all(isim)) xnew <- as.solist(xnew) return(xnew) } spatstat.geom/R/texture.R0000644000176200001440000003252014722270352015075 0ustar liggesusers## ## texture.R ## ## Texture plots and texture maps ## ## $Revision: 1.19 $ $Date: 2024/11/29 07:44:37 $ ### .................. basic graphics ............................. ## put hatching in a window add.texture <- function(W, texture=4, spacing=NULL, ...) { if(is.data.frame(texture)) { ## texture = f(x) where f is a texturemap out <- do.call(add.texture, resolve.defaults(list(W=quote(W), spacing=spacing), list(...), as.list(texture))) return(out) } ## texture should be an integer stopifnot(is.owin(W)) stopifnot(texture %in% 1:8) if(is.null(spacing)) { spacing <- diameter(as.rectangle(W))/50 } else { check.1.real(spacing) stopifnot(spacing > 0) } P <- L <- NULL switch(texture, { ## texture 1: graveyard P <- rsyst(W, dx=3*spacing) }, { ## texture 2: vertical lines L <- rlinegrid(90, spacing, W) }, { ## texture 3: horizontal lines L <- rlinegrid(0, spacing, W) }, { ## texture 4: forward slashes L <- rlinegrid(45, spacing, W) }, { ## texture 5: back slashes L <- rlinegrid(135, spacing, W) }, { ## texture 6: horiz/vert grid L0 <- rlinegrid(0, spacing, W) L90 <- rlinegrid(90, spacing, W) L <- superimpose(L0, L90, W=W, check=FALSE) }, { ## texture 7: diagonal grid L45 <- rlinegrid(45, spacing, W) L135 <- rlinegrid(135, spacing, W) L <- superimpose(L45, L135, W=W, check=FALSE) }, { ## texture 8: hexagons H <- hextess(W, spacing, offset=runifrect(1, Frame(W)), trim=TRUE) dont.complain.about(H) do.call.matched(plot.tess, resolve.defaults(list(x=quote(H), add=TRUE), list(...))) }) if(!is.null(P)) do.call.matched(plot.ppp, resolve.defaults(list(x=quote(P), add=TRUE), list(...), list(chars=3, cex=0.2)), extrargs=c("lwd", "col", "cols", "pch")) if(!is.null(L)) do.call.matched(plot.psp, resolve.defaults(list(x=quote(L), add=TRUE), list(...)), extrargs=c("lwd","lty","col")) return(invisible(NULL)) } ## .................. texture maps ................................ ## create a texture map texturemap <- function(inputs, textures, ...) { argh <- list(...) if(length(argh) > 0) { isnul <- unlist(lapply(argh, is.null)) argh <- argh[!isnul] } if(missing(textures) || is.null(textures)) textures <- seq_along(inputs) df <- do.call(data.frame, append(list(input=inputs, texture=textures), argh)) f <- function(x) { df[match(x, df$input), -1, drop=FALSE] } class(f) <- c("texturemap", class(f)) attr(f, "df") <- df return(f) } print.texturemap <- function(x, ...) { cat("Texture map\n") print(attr(x, "df")) return(invisible(NULL)) } ## plot a texture map plot.texturemap <- local({ ## recognised additional arguments to and axis() axisparams <- c("cex", "cex.axis", "cex.lab", "col.axis", "col.lab", "font.axis", "font.lab", "las", "mgp", "xaxp", "yaxp", "tck", "tcl", "xpd") # rules to determine the map dimensions when one dimension is given widthrule <- function(heightrange, separate, n, gap) { if(separate) 1 else diff(heightrange)/10 } heightrule <- function(widthrange, separate, n, gap) { (if(separate) (n + (n-1)*gap) else 10) * diff(widthrange) } sideCode <- function(side) { if(is.numeric(side)) { stopifnot(side %in% 1:4) sidecode <- side } else if(is.character(side)) { nama <- c("bottom", "left", "top", "right") side <- match.arg(side, nama) sidecode <- match(side, nama) } else stop("Unrecognised format for 'side'") return(sidecode) } plot.texturemap <- function(x, ..., main, xlim=NULL, ylim=NULL, vertical=FALSE, axis=TRUE, side = if(vertical) "right" else "bottom", labelmap=NULL, gap=0.25, spacing=NULL, add=FALSE) { if(missing(main)) main <- short.deparse(substitute(x)) df <- attr(x, "df") # textures <- df$textures n <- nrow(df) check.1.real(gap, "In plot.texturemap") explain.ifnot(gap >= 0, "In plot.texturemap") separate <- (gap > 0) if(is.null(labelmap)) { labelmap <- function(x) x } else stopifnot(is.function(labelmap)) if(missing(vertical) && !missing(side)) vertical <- (sideCode(side) %in% c(2, 4)) ## determine rectangular window for display rr <- c(0, n + (n-1)*gap) if(is.null(xlim) && is.null(ylim)) { u <- widthrule(rr, separate, n, gap) if(!vertical) { xlim <- rr ylim <- c(0,u) } else { xlim <- c(0,u) ylim <- rr } } else if(is.null(ylim)) { if(!vertical) ylim <- c(0, widthrule(xlim, separate, n, gap)) else ylim <- c(0, heightrule(xlim, separate, n, gap)) } else if(is.null(xlim)) { if(!vertical) xlim <- c(0, heightrule(ylim, separate, n, gap)) else xlim <- c(0, widthrule(ylim, separate, n, gap)) } width <- diff(xlim) height <- diff(ylim) ## determine boxes to be filled with textures, if(vertical) { boxheight <- min(width, height/(n + (n-1) * gap)) vgap <- (height - n * boxheight)/(n-1) boxes <- list() for(i in 1:n) boxes[[i]] <- owinInternalRect(xlim, ylim[1] + c(i-1, i) * boxheight + (i-1) * vgap) } else { boxwidth <- min(height, width/(n + (n-1) * gap)) hgap <- (width - n * boxwidth)/(n-1) boxes <- list() for(i in 1:n) boxes[[i]] <- owinInternalRect(xlim[1] + c(i-1, i) * boxwidth + (i-1) * hgap, ylim) } boxsize <- shortside(boxes[[1]]) if(is.null(spacing)) spacing <- 0.1 * boxsize # .......... initialise plot ............................... if(!add) do.call.matched(plot.default, resolve.defaults(list(x=xlim, y=ylim, type="n", main=main, axes=FALSE, xlab="", ylab="", asp=1.0), list(...))) ## ................ plot texture blocks ................. for(i in 1:n) { dfi <- df[i,,drop=FALSE] add.texture(W=boxes[[i]], texture=dfi, ..., spacing=spacing) plot(boxes[[i]], add=TRUE) } if(axis) { # ................. draw annotation .................. la <- paste(labelmap(df$input)) if(!vertical) { ## add horizontal axis/annotation at <- lapply(lapply(boxes, centroid.owin), "getElement", name="x") sidecode <- sideCode(side) if(!(sidecode %in% c(1,3))) warning(paste("side =", if(is.character(side)) sQuote(side) else side, "is not consistent with horizontal orientation")) pos <- c(ylim[1], xlim[1], ylim[2], xlim[2])[sidecode] # don't draw axis lines if plotting separate blocks lwd0 <- if(separate) 0 else 1 # draw axis do.call.matched(graphics::axis, resolve.defaults(list(...), list(side = sidecode, pos = pos, at = at), list(labels=la, lwd=lwd0)), extrargs=axisparams) } else { ## add vertical axis at <- lapply(lapply(boxes, centroid.owin), "getElement", name="y") # default axis position is to the right of ribbon (side=4) sidecode <- sideCode(side) if(!(sidecode %in% c(2,4))) warning(paste("side =", if(is.character(side)) sQuote(side) else side, "is not consistent with vertical orientation")) pos <- c(ylim[1], xlim[1], ylim[2], xlim[2])[sidecode] # don't draw axis lines if plotting separate blocks lwd0 <- if(separate) 0 else 1 # draw labels horizontally if plotting separate blocks las0 <- if(separate) 1 else 0 # draw axis do.call.matched(graphics::axis, resolve.defaults(list(...), list(side=sidecode, pos=pos, at=at), list(labels=la, lwd=lwd0, las=las0)), extrargs=axisparams) } } invisible(NULL) } plot.texturemap }) ## plot a pixel image using textures textureplot <- local({ textureplot <- function(x, ..., main, add=FALSE, clipwin=NULL, do.plot=TRUE, border=NULL, col=NULL, lwd=NULL, lty=NULL, spacing=NULL, textures=1:8, legend=TRUE, leg.side=c("right", "left", "bottom", "top"), legsep=0.1, legwid=0.2) { if(missing(main)) main <- short.deparse(substitute(x)) if(!(is.im(x) || is.tess(x))) { x <- try(as.tess(x), silent=TRUE) if(inherits(x, "try-error")) x <- try(as.im(x), silent=TRUE) if(inherits(x, "try-error")) stop("x must be a pixel image or a tessellation", call.=FALSE) } leg.side <- match.arg(leg.side) if(!is.null(clipwin)) x <- x[clipwin, drop=FALSE] if(is.im(x)) { if(x$type != "factor") x <- eval.im(factor(x)) levX <- levels(x) } else { tilX <- tiles(x) levX <- names(tilX) } n <- length(levX) if(n > 8) stop("Too many factor levels or tiles: maximum is 8") ## determine texture map if(inherits(textures, "texturemap")) { tmap <- textures } else { stopifnot(all(textures %in% 1:8)) stopifnot(length(textures) >= n) mono <- spatstat.options("monochrome") col <- enforcelength(col, n, if(mono) 1 else 1:8) lwd <- if(is.null(lwd)) NULL else enforcelength(lwd, n, 1) lty <- if(is.null(lty)) NULL else enforcelength(lwd, n, 1) tmap <- texturemap(inputs=levX, textures=textures[1:n], col=col, lwd=lwd, lty=lty) } ## determine plot region bb <- as.rectangle(x) if(!legend) { bb.all <- bb } else { Size <- max(sidelengths(bb)) bb.leg <- switch(leg.side, right={ ## legend to right of image owinInternalRect(bb$xrange[2] + c(legsep, legsep+legwid) * Size, bb$yrange) }, left={ ## legend to left of image owinInternalRect(bb$xrange[1] - c(legsep+legwid, legsep) * Size, bb$yrange) }, top={ ## legend above image owinInternalRect(bb$xrange, bb$yrange[2] + c(legsep, legsep+legwid) * Size) }, bottom={ ## legend below image owinInternalRect(bb$xrange, bb$yrange[1] - c(legsep+legwid, legsep) * Size) }) iside <- match(leg.side, c("bottom", "left", "top", "right")) bb.all <- boundingbox(bb.leg, bb) } ## result <- tmap attr(result, "bbox") <- bb ## if(do.plot) { ## Plot textures if(!add) { switch(leg.side, left = , right = { bb.full <- bb.all bb.titled <- bb }, bottom = , top = { bb.full <- grow.rectangle(bb.all, 0, c(0, 0.1 * diff(bb.all$yrange))) bb.titled <- bb.all }) plot(bb.full, type="n", main="") fakemaintitle(bb.titled, main, ...) } if(is.null(spacing)) spacing <- diameter(as.rectangle(x))/50 areas <- if(is.im(x)) table(x$v) else tile.areas(x) for(i in which(areas > 0)) { Zi <- if(is.tess(x)) tilX[[i]] else levelset(x, levX[i], "==") Zi <- as.polygonal(Zi) if(is.null(border) || !is.na(border)) plot(Zi, add=TRUE, border=border) add.texture(Zi, texture=tmap(levX[i]), spacing=spacing, ...) } vertical <- leg.side %in% c("left", "right") if(legend) do.call(plot.texturemap, resolve.defaults(list(x=quote(tmap), add=TRUE, vertical=vertical, side=iside, xlim=bb.leg$xrange, ylim=bb.leg$yrange, spacing=spacing), list(...))) } return(invisible(result)) } enforcelength <- function(x, n, x0) { if(is.null(x)) x <- x0 if(length(x) < n) x <- rep(x, n) return(x[1:n]) } textureplot }) spatstat.geom/R/centroid.R0000644000176200001440000001016214611065351015200 0ustar liggesusers# # centroid.S Centroid of a window # and related operations # # $Revision: 1.7 $ $Date: 2022/01/04 05:30:06 $ # # Function names (followed by "xypolygon" or "owin") # # intX integral of x dx dy # intY integral of y dx dy # meanX mean of x dx dy # meanY mean of y dx dy # centroid (meanX, meanY) # #------------------------------------- intX.xypolygon <- function(polly) { # # polly: list(x,y) vertices of a single polygon (n joins to 1) # verify.xypolygon(polly) x <- polly$x y <- polly$y # nedges <- length(x) # sic # place x axis below polygon y <- y - min(y) # join vertex n to vertex 1 xr <- c(x, x[1L]) yr <- c(y, y[1L]) # slope dx <- diff(xr) dy <- diff(yr) slope <- ifelseAX(dx == 0, 0, dy/dx) # integrate integrals <- x * y * dx + (y + slope * x) * (dx^2)/2 + slope * (dx^3)/3 -sum(integrals) } intX.owin <- function(w) { verifyclass(w, "owin") switch(w$type, rectangle = { width <- abs(diff(w$xrange)) height <- abs(diff(w$yrange)) answer <- width * height * mean(w$xrange) }, polygonal = { answer <- sum(unlist(lapply(w$bdry, intX.xypolygon))) }, mask = { pixelarea <- abs(w$xstep * w$ystep) x <- rasterx.mask(w, drop=TRUE) answer <- (pixelarea * length(x)) * mean(x) }, stop("Unrecognised window type") ) return(answer) } meanX.owin <- function(w) { verifyclass(w, "owin") switch(w$type, rectangle = { answer <- mean(w$xrange) }, polygonal = { area <- sum(unlist(lapply(w$bdry, Area.xypolygon))) integrated <- sum(unlist(lapply(w$bdry, intX.xypolygon))) answer <- integrated/area }, mask = { x <- rasterx.mask(w, drop=TRUE) answer <- mean(x) }, stop("Unrecognised window type") ) return(answer) } intY.xypolygon <- function(polly) { # # polly: list(x,y) vertices of a single polygon (n joins to 1) # verify.xypolygon(polly) x <- polly$x y <- polly$y # nedges <- length(x) # sic # place x axis below polygon yadjust <- min(y) y <- y - yadjust # join vertex n to vertex 1 xr <- c(x, x[1L]) yr <- c(y, y[1L]) # slope dx <- diff(xr) dy <- diff(yr) slope <- ifelseAX(dx == 0, 0, dy/dx) # integrate integrals <- (1/2) * (dx * y^2 + slope * y * dx^2 + slope^2 * dx^3/3) total <- sum(integrals) - yadjust * Area.xypolygon(polly) # change sign to adhere to anticlockwise convention -total } intY.owin <- function(w) { verifyclass(w, "owin") switch(w$type, rectangle = { width <- abs(diff(w$xrange)) height <- abs(diff(w$yrange)) answer <- width * height * mean(w$yrange) }, polygonal = { answer <- sum(unlist(lapply(w$bdry, intY.xypolygon))) }, mask = { pixelarea <- abs(w$xstep * w$ystep) y <- rastery.mask(w, drop=TRUE) answer <- (pixelarea * length(y)) * mean(y) }, stop("Unrecognised window type") ) return(answer) } meanY.owin <- function(w) { verifyclass(w, "owin") switch(w$type, rectangle = { answer <- mean(w$yrange) }, polygonal = { area <- sum(unlist(lapply(w$bdry, Area.xypolygon))) integrated <- sum(unlist(lapply(w$bdry, intY.xypolygon))) answer <- integrated/area }, mask = { y <- rastery.mask(w, drop=TRUE) answer <- mean(y) }, stop("Unrecognised window type") ) return(answer) } centroid.owin <- function(w, as.ppp = FALSE) { w <- as.owin(w) out <- list(x=meanX.owin(w), y=meanY.owin(w)) if(as.ppp){ if(!inside.owin(out$x, out$y, w)) w <- as.rectangle(w) out <- as.ppp(out, W=w) } return(out) } spatstat.geom/R/superimpose.R0000644000176200001440000001423614611065352015753 0ustar liggesusers# superimpose.R # # $Revision: 1.39 $ $Date: 2020/06/13 08:56:57 $ # # ############################# superimpose <- function(...) { # remove any NULL arguments arglist <- list(...) if(any(isnull <- sapply(arglist, is.null))) return(do.call(superimpose, arglist[!isnull])) UseMethod("superimpose") } superimpose.default <- function(...) { argh <- list(...) #' First expand any arguments which are lists of objects argh <- expandSpecialLists(argh, "solist") #' Now dispatch if(any(sapply(argh, is.lpp)) || any(sapply(argh, inherits, what="linnet"))) { if(!requireNamespace("spatstat.linnet")) { warning(paste("superimposing point patterns on a linear network", "requires the package 'spatstat.linnet'"), call.=FALSE) return(NULL) } return(do.call(spatstat.linnet::superimpose.lpp, argh)) } if(any(sapply(argh, is.psp))) return(do.call(superimpose.psp, argh)) #' default return(do.call(superimpose.ppp, argh)) } superimpose.ppp <- function(..., W=NULL, check=TRUE) { arglist <- list(...) # Check that all "..." arguments have x, y coordinates hasxy <- unlist(lapply(arglist, checkfields, L=c("x", "y"))) if(!all(hasxy)) { nbad <- sum(bad <- !hasxy) stop(paste(ngettext(nbad, "Argument", "Arguments"), commasep(which(bad)), ngettext(nbad, "does not", "do not"), "have components x and y"), call.=FALSE) } # concatenate lists of (x,y) coordinates XY <- do.call(concatxy, arglist) needcheck <- TRUE # determine whether there is any window information if(!is.owin(W)) { ## we have to compute the final window if(is.function(W)) { ## W is a function like bounding.box.xy or ripras ## Apply function to the x,y coordinates; it should return an owin WXY <- W(XY) if(!is.owin(WXY)) stop("Function W did not return an owin object", call.=FALSE) W <- WXY } else if(is.character(W)) { ## character string identifies a function pW <- pmatch(W, c("convex", "rectangle", "bbox", "none")) if(is.na(pW)) stop(paste("Unrecognised option W=", sQuote(W)), call.=FALSE) WXY <- switch(pW, convex=ripras(XY), rectangle=ripras(XY, shape="rectangle"), bbox=boundingbox(XY), none=NULL) # in these cases we don't need to verify that the points are inside. needcheck <- !is.null(WXY) if(!is.null(WXY)) W <- WXY } else if(is.null(W)) { if(any(isppp <- unlist(lapply(arglist, is.ppp)))) { ## extract windows from ppp objects wins <- unname(lapply(arglist[isppp], as.owin)) ## take union W <- if(length(wins) == 1) wins[[1]] else do.call(union.owin, wins) } else { ## no window information return(XY) } } else stop("Argument W is not understood") } # extract the marks if any nobj <- lengths(lapply(arglist, getElement, name="x")) marx <- superimposeMarks(arglist, nobj) # ppp(XY$x, XY$y, window=W, marks=marx, check=check & needcheck) } superimpose.splitppp <- superimpose.ppplist <- function(..., W=NULL, check=TRUE) { arglist <- list(...) while(any(h <- sapply(arglist, inherits, what=c("splitppp", "ppplist")))) { i <- min(which(h)) arglist <- insertinlist(arglist, i, arglist[[i]]) } do.call(superimpose, append(arglist, list(W=W, check=check))) } superimpose.psp <- function(..., W=NULL, check=TRUE) { # superimpose any number of line segment patterns arglist <- list(...) misscheck <- missing(check) if(!all(sapply(arglist, is.psp))) stop("Patterns to be superimposed must all be psp objects", call.=FALSE) # extract segment coordinates matlist <- lapply(lapply(arglist, getElement, name="ends"), asNumericMatrix) # tack them together mat <- do.call(rbind, matlist) # determine whether there is any window information needcheck <- FALSE if(!is.owin(W)) { # we have to compute the final window WXY <- NULL # Wpsp <- NULL if(any(ispsp <- unlist(lapply(arglist, is.psp)))) { # extract windows from psp objects wins <- unname(lapply(arglist[ispsp], as.owin)) # take union Wppp <- if(length(wins) == 1) wins[[1]] else do.call(union.owin, wins) } if(is.function(W) || is.character(W)) { # guess window from x, y coordinates XY <- list(x=cbind(mat[,1], mat[,3]), y=cbind(mat[,2], mat[,4])) if(is.function(W)) { # W is a function like bounding.box.xy or ripras # Apply function to the x,y coordinates; it should return an owin WXY <- W(XY) if(!is.owin(WXY)) stop("Function W did not return an owin object", call.=FALSE) } if(is.character(W)) { # character string identifies a function pW <- pmatch(W, c("convex", "rectangle", "bbox", "none")) if(is.na(pW)) stop(paste("Unrecognised option W=", sQuote(W)), call.=FALSE) WXY <- switch(pW, convex=ripras(XY), rectangle=ripras(XY, shape="rectangle"), bbox=boundingbox(XY), none=NULL) # in these cases we don't need to verify that the points are inside. needcheck <- !is.null(WXY) } } W <- union.owin(WXY, Wppp) } # extract marks, if any nobj <- sapply(arglist, nsegments) marx <- superimposeMarks(arglist, nobj) if(misscheck && !needcheck) check <- FALSE return(as.psp(mat, window=W, marks=marx, check=check)) } superimposeMarks <- function(arglist, nobj) { # combine marks from the objects in the argument list marxlist <- lapply(arglist, marks) marx <- do.call(markappend, unname(marxlist)) nama <- names(arglist) if(length(nama) == length(arglist) && all(nzchar(nama))) { # arguments are named: use names as (extra) marks newmarx <- factor(rep.int(nama, nobj), levels=nama) marx <- markcbind(marx, newmarx) if(ncol(marx) == 2) { ## component marks were not named: call them 'origMarks' colnames(marx) <- c("origMarks", "pattern") } else colnames(marx)[ncol(marx)] <- "pattern" } return(marx) } spatstat.geom/R/ppp.R0000644000176200001440000005342014633444363014204 0ustar liggesusers# # ppp.R # # A class 'ppp' to define point patterns # observed in arbitrary windows in two dimensions. # # $Revision: 4.118 $ $Date: 2024/06/16 02:03:00 $ # # A point pattern contains the following entries: # # $window: an object of class 'owin' # defining the observation window # # $n: the number of points (for efficiency) # # $x: # $y: vectors of length n giving the Cartesian # coordinates of the points. # # It may also contain the entry: # # $marks: a vector of length n # whose entries are interpreted as the # 'marks' attached to the corresponding points. # #-------------------------------------------------------------------------- ppp <- function(x, y, ..., window, marks, check=TRUE, checkdup=check, drop=TRUE) { # Constructs an object of class 'ppp' # if(!missing(window)) verifyclass(window, "owin") else window <- owin(...) if((missing(x) && missing(y)) || (length(x) == 0 && length(y) == 0)) x <- y <- numeric(0) n <- length(x) if(length(y) != n) stop("coordinate vectors x and y are not of equal length") # validate x, y coordinates stopifnot(is.numeric(x)) stopifnot(is.numeric(y)) good <- is.finite(x) & is.finite(y) if(naughty <- !all(good)) { #' bad values will be discarded nbad <- sum(!good) nna <- sum(is.na(x) | is.na(y)) ninf <- nbad - nna if(nna > 0) warning(paste(nna, "out of", n, ngettext(n, "point", "points"), "had NA or NaN coordinate values, and", ngettext(nna, "was", "were"), "discarded")) if(ninf > 0) warning(paste(ninf, "out of", n, ngettext(n, "point", "points"), "had infinite coordinate values, and", ngettext(ninf, "was", "were"), "discarded")) #' chuck out x <- x[good] y <- y[good] n <- sum(good) } names(x) <- NULL names(y) <- NULL # check (x,y) points lie inside window if(check && n > 0) { ok <- inside.owin(x, y, window) nout <- sum(!ok) if(nout > 0) { warning(paste(nout, ngettext(nout, "point was", "points were"), "rejected as lying outside the specified window"), call.=FALSE) rr <- ripras(x,y) bb <- boundingbox(x,y) bb <- boundingbox(rr, bb, window) rejectwindow <- if(!is.null(rr)) rebound.owin(rr, bb) else bb rejects <- ppp(x[!ok], y[!ok], window=rejectwindow, check=FALSE) # discard illegal points x <- x[ok] y <- y[ok] n <- length(x) } } else nout <- 0 # initialise ppp object pp <- list(window=window, n=n, x=x, y=y) # coerce marks to appropriate format if(missing(marks)) marks <- NULL if(is.hyperframe(marks)) stop("Hyperframes of marks are not implemented for ppp objects; use ppx") if(is.matrix(marks)) marks <- as.data.frame(marks) ## drop dimensions? if(drop && is.data.frame(marks)) { nc <- ncol(marks) if(nc == 0) marks <- NULL else if(nc == 1) marks <- marks[,,drop=TRUE] } # attach marks if(is.null(marks)) { # no marks pp$markformat <- "none" } else if(is.data.frame(marks)) { # data frame of marks pp$markformat <- "dataframe" if(naughty) { #' remove marks attached to discarded points with non-finite coordinates marks <- marks[good, ] } if(nout > 0) { #' sequester marks of points falling outside window marks(rejects) <- marks[!ok,] marks <- marks[ok, ] } if(nrow(marks) != n) stop("number of rows of marks != length of x and y") pp$marks <- marks } else { # should be a vector or factor # To recognise vector, strip attributes isspecial <- is.factor(marks) || inherits(marks, "POSIXt") || inherits(marks, "Date") if(!isspecial) attributes(marks) <- NULL if(!(is.vector(marks) || isspecial)) stop("Format of marks not understood") # OK, it's a vector or factor pp$markformat <- "vector" if(naughty) { #' remove marks attached to discarded points with non-finite coordinates marks <- marks[good] } if(nout > 0) { #' sequester marks of points falling outside window marks(rejects) <- marks[!ok] marks <- marks[ok] } if(length(marks) != n) stop("length of marks vector != length of x and y") names(marks) <- NULL pp$marks <- marks } class(pp) <- "ppp" if(checkdup && anyDuplicated(pp)) warning("data contain duplicated points", call.=FALSE) if(nout > 0) attr(pp, "rejects") <- rejects pp } # #-------------------------------------------------------------------------- # is.ppp <- function(x) { inherits(x, "ppp") } # #-------------------------------------------------------------------------- # as.ppp <- function(X, ..., fatal=TRUE) { UseMethod("as.ppp") } as.ppp.ppp <- function(X, ..., fatal=TRUE) { check <- isTRUE(list(...)$check) # default FALSE return(ppp(X$x, X$y, window=X$window, marks=X$marks, check=check)) } as.ppp.quad <- function(X, ..., fatal=TRUE) { return(union.quad(X)) } as.ppp.data.frame <- function(X, W = NULL, ..., fatal=TRUE) { X <- as.data.frame(X) #' swim against the tidyverse if(ncol(X) < 2) return(complaining("X must have at least two columns", fatal, value=NULL)) if(is.null(W)) return(complaining("x,y coords given but no window specified", fatal, value=NULL)) # columns 1 and 2 are assumed to be coordinates # marks from other columns marx <- if(ncol(X) > 2) X[, -(1:2)] else NULL if(is.function(W)) Z <- cobble.xy(x=X[,1], y=X[,2], f=W, fatal=fatal, marks=marx, ...) else { win <- as.owin(W) Z <- ppp(x=X[,1], y=X[,2], window = win, marks=marx, ...) } return(Z) } as.ppp.matrix <- function(X, W = NULL, ..., fatal=TRUE) { check <- !isFALSE(list(...)$check) # default TRUE if(!verifyclass(X, "matrix", fatal=fatal) || !is.numeric(X)) return(complaining("X must be a numeric matrix", fatal, value=NULL)) if(ncol(X) < 2) return(complaining("X must have at least two columns", fatal, value=NULL)) if(is.null(W)) return(complaining("x,y coords given but no window specified", fatal, value=NULL)) if(is.function(W)) Z <- cobble.xy(X[,1], X[,2], W, fatal, check=check) else { win <- as.owin(W) Z <- ppp(X[,1], X[,2], window = win, check=check) } # add marks from other columns if(ncol(X) > 2) marks(Z) <- X[, -(1:2)] return(Z) } as.ppp.default <- function(X, W=NULL, ..., fatal=TRUE) { # tries to coerce data X to a point pattern # X may be: # 1. a structure with entries x, y, xl, xu, yl, yu # 2. a structure with entries x, y, area where # 'area' has entries xl, xu, yl, yu # 3. a structure with entries x, y # 4. a vector of length 2, interpreted as a single point. # The second argument W is coerced to an object of class 'owin' by the # function "as.owin" in window.S # If X also has an entry X$marks # then this will be interpreted as the marks vector for the pattern. # check <- resolve.defaults(list(...), list(check=TRUE))$check if(checkfields(X, c("x", "y", "xl", "xu", "yl", "yu"))) { xrange <- c(X$xl, X$xu) yrange <- c(X$yl, X$yu) if(is.null(X$marks)) Z <- ppp(X$x, X$y, xrange, yrange, check=check) else Z <- ppp(X$x, X$y, xrange, yrange, marks=X$marks, check=check) return(Z) } else if(checkfields(X, c("x", "y", "area")) && checkfields(X$area, c("xl", "xu", "yl", "yu"))) { win <- as.owin(X$area) if (is.null(X$marks)) Z <- ppp(X$x, X$y, window=win, check=check) else Z <- ppp(X$x, X$y, window=win, marks = X$marks, check=check) return(Z) } else if(checkfields(X, c("x", "y"))) { if(is.function(W)) return(cobble.xy(X$x, X$y, W, fatal)) if(is.null(W)) { if(fatal) stop("x,y coords given but no window specified") else return(NULL) } win <- as.owin(W) if(is.null(X$marks)) Z <- ppp(X$x, X$y, window=win, check=check) else Z <- ppp(X$x, X$y, window=win, marks=X$marks, check=check) return(Z) } else if(is.vector(X) && length(X) == 2) { win <- as.owin(W) Z <- ppp(X[1], X[2], window=win, check=check) return(Z) } else { if(fatal) stop("Can't interpret X as a point pattern") else return(NULL) } } cobble.xy <- function(x, y, f=ripras, fatal=TRUE, ...) { if(!is.function(f)) stop("f is not a function") w <- f(x,y) if(!is.owin(w)) { gripe <- "Supplied function f did not return an owin object" if(fatal) stop(gripe) else { warning(gripe) return(NULL) } } return(ppp(x, y, window=w, ...)) } # -------------------------------------------------------------- "[.ppp" <- function(x, i, j, drop=FALSE, ..., clip=FALSE) { verifyclass(x, "ppp") if(!missing(i)) { if(inherits(i, "owin")) { # i is a window window <- i if(clip) window <- intersect.owin(window, x$window) if(is.vanilla(unitname(window))) unitname(window) <- unitname(x) ok <- inside.owin(x$x, x$y, window) x <- ppp(x$x[ok], x$y[ok], window=window, #SIC marks=marksubset(x$marks, ok), check=FALSE) } else if(inherits(i, "im")) { # i is an image if(i$type != "logical") stop(paste("Subset operator X[i] undefined", "when i is a pixel image", "unless it has logical values"), call.=FALSE) # convert logical image to window e <- sys.frame(sys.nframe()) window <- solutionset(i, e) if(clip) window <- intersect.owin(window, x$window) ok <- inside.owin(x$x, x$y, window) x <- ppp(x$x[ok], x$y[ok], window=window, #SIC marks=marksubset(x$marks, ok), check=FALSE) } else { # assume i is a subset index nx <- x$n if(nx == 0) return(x) subset <- seq_len(nx)[i] if(anyNA(subset)) stop("Index out of bounds in [.ppp", call.=FALSE) x <- ppp(x$x[subset], x$y[subset], window=x$window, marks=marksubset(x$marks, subset), check=FALSE) } } if(!missing(j)) x <- x[j] # invokes code above if(drop) { #' drop unused factor levels mx <- x$marks switch(markformat(mx), none = { }, vector = { if(is.factor(mx)) marks(x) <- factor(mx) # this preserves order of levels }, dataframe = { #' must be an actual data frame, not a matrix if(is.data.frame(mx)) { ml <- as.list(mx) isfac <- sapply(ml, is.factor) if(any(isfac)) mx[, isfac] <- as.data.frame(lapply(ml[isfac], factor)) } }, hyperframe = { }) } return(x) } # ------------------------------------------------------------------ # # scanpp <- function(filename, window, header=TRUE, dir="", factor.marks = NULL, ...) { filename <- if(dir=="") filename else paste(dir, filename, sep=.Platform$file.sep) df <- read.table(filename, header=header, stringsAsFactors = is.null(factor.marks)) if(header) { # check whether there are columns named 'x' and 'y' colnames <- dimnames(df)[[2]] xycolumns <- match(c("x", "y"), colnames, 0) named <- all(xycolumns > 0) } else { named <- FALSE } if(named) { x <- df$x y <- df$y } else { # assume x, y given in columns 1, 2 respectively x <- df[,1] y <- df[,2] xycolumns <- c(1,2) } if(ncol(df) == 2) X <- ppp(x, y, window=window) else { # Catch old argument "multitype": dots <- list(...) multi <- charmatch(names(dots), "multitype") argindex <- which(!is.na(multi)) if(length(argindex)>0){ if(missing(factor.marks)){ factor.marks <- dots[[argindex]] ignored <- "" } else{ ignored <- paste(" and it is ignored since", sQuote("factor.marks"), "is also supplied") } warning("It appears you have called scanpp ", " with (something partially matching) ", " the deprecated argument ", paste0(sQuote("multitype"), ignored, "."), " Please change to the new syntax.") } marks <- df[ , -xycolumns, drop=FALSE] if(any(factor.marks)){ # Find indices to convert to factors (recycling to obtain correct length) factorid <- (1:ncol(marks))[factor.marks] # Convert relevant columns to factors marks[,factorid] <- lapply(marks[,factorid,drop=FALSE], factor) } X <- ppp(x, y, window=window, marks = marks) } X } #------------------------------------------------------------------- "markspace.integral" <- function(X) { verifyclass(X, "ppp") if(!is.marked(X, dfok=TRUE)) return(1) if(is.multitype(X)) return(length(levels(marks(X)))) else stop("Don't know how to compute total mass of mark space") } #------------------------------------------------------------------- print.ppp <- function(x, ...) { verifyclass(x, "ppp") ism <- is.marked(x, dfok=TRUE) nx <- x$n splat(if(ism) "Marked planar" else "Planar", "point pattern:", nx, ngettext(nx, "point", "points")) if(ism) { mks <- marks(x, dfok=TRUE) if(is.data.frame(mks)) { ## data frame of marks exhibitStringList("Mark variables:", names(mks)) } else { ## vector of marks if(is.factor(mks)) { exhibitStringList("Multitype, with levels =", levels(mks)) } else { ## Numeric, or could be dates if(inherits(mks, "Date")) { splat("marks are dates, of class", sQuote("Date")) } else if(inherits(mks, "POSIXt")) { splat("marks are dates, of class", sQuote("POSIXt")) } else { splat(paste0("marks are", if(is.numeric(mks)) " numeric," else NULL), "of storage type ", sQuote(typeof(mks))) } } } } print(x$window) terselevel <- spatstat.options('terse') if(waxlyrical('errors', terselevel) && !is.null(rejects <- attr(x, "rejects"))) { nrejects <- rejects$n splat("***", nrejects, ngettext(nrejects, "illegal point", "illegal points"), "stored in", paste0("attr(,", dQuote("rejects"), ")"), "***") } if(waxlyrical('extras', terselevel) && !is.null(info <- attr(x, "info")) && inherits(info, "rmhInfoList")) { ## hack to avoid 'require(spatstat.core)' ispois <- identical(info$model$cif, 'poisson') splat("Pattern was generated by", if(ispois) "Poisson" else "Metropolis-Hastings", "simulation.") } return(invisible(NULL)) } summary.ppp <- function(object, ..., checkdup=TRUE) { verifyclass(object, "ppp") result <- list() result$is.marked <- is.marked(object, dfok=TRUE) result$n <- object$n result$window <- summary(object$window) result$intensity <- result$n/result$window$area if(checkdup) { result$nduplicated <- sum(duplicated(object)) result$rounding <- rounding(object) } if(result$is.marked) { mks <- marks(object, dfok=TRUE) if(result$multiple.marks <- is.data.frame(mks)) { result$marknames <- names(mks) result$is.numeric <- FALSE result$marktype <- "dataframe" result$is.multitype <- FALSE } else { result$is.numeric <- is.numeric(mks) result$marknames <- "marks" result$marktype <- typeof(mks) result$is.multitype <- is.multitype(object) } if(result$is.multitype) { tm <- as.vector(table(mks)) tfp <- data.frame(frequency=tm, proportion=tm/sum(tm), intensity=tm/result$window$area, row.names=levels(mks)) result$marks <- tfp } else result$marks <- summary(mks) } class(result) <- "summary.ppp" if(!is.null(rejects <- attr(object, "rejects"))) result$rejects <- rejects$n if(!is.null(info <- attr(object, "info")) && inherits(info, "rmhInfoList")) result$rmhinfo <- info return(result) } print.summary.ppp <- function(x, ..., dp=getOption("digits")) { verifyclass(x, "summary.ppp") terselevel <- spatstat.options("terse") splat(if(x$is.marked) "Marked planar" else "Planar", "point pattern: ", x$n, "points") oneline <- resolve.defaults(list(...), list(oneline=FALSE))$oneline if(oneline) return(invisible(NULL)) unitinfo <- summary(x$window$units) splat("Average intensity", signif(x$intensity,dp), "points per square", unitinfo$singular, unitinfo$explain) ndup <- x$nduplicated if(waxlyrical('extras', terselevel) && !is.null(ndup) && (ndup > 0)) { parbreak(terselevel) splat("*Pattern contains duplicated points*") } rndg <- x$rounding if(waxlyrical('gory', terselevel) && !is.null(rndg)) { cat("\n") if(rndg >= 1) { cat("Coordinates are", "given to", rndg, "decimal", ngettext(rndg, "place", "places"), fill=TRUE) if(rndg <= 3) { cat("i.e. rounded to", "the nearest", "multiple of", 10^(-rndg), unitinfo$plural, unitinfo$explain, fill=TRUE) } } else if(rndg == 0) { cat("Coordinates are", "integers", fill=TRUE) cat("i.e. rounded to", "the nearest", unitinfo$singular, unitinfo$explain, fill=TRUE) } else { cat("Coordinates are", "multiples of", 10^(-rndg), unitinfo$plural, unitinfo$explain, fill=TRUE) } parbreak(terselevel) } if(x$is.marked) { if(x$multiple.marks) { splat("Mark variables:", commasep(x$marknames, ", ")) cat("Summary:\n") print(x$marks) } else if(x$is.multitype) { cat("Multitype:\n") print(signif(x$marks,dp)) } else { splat("marks are ", if(x$is.numeric) "numeric, ", "of type ", sQuote(x$marktype), sep="") cat("Summary:\n") print(x$marks) } parbreak(terselevel) } if(waxlyrical('extras', terselevel)) print(x$window) if(waxlyrical('errors', terselevel) && !is.null(nrejects <- x$rejects)) { parbreak(terselevel) splat("***", nrejects, ngettext(nrejects, "illegal point", "illegal points"), "stored in", paste("attr(,", dQuote("rejects"), ")", sep=""), "***") } if(waxlyrical('gory', terselevel) && !is.null(info <- x$rmhinfo)) { cat("\nPattern was generated by", "Metropolis-Hastings algorithm rmh", fill=TRUE) print(info) } return(invisible(x)) } # --------------------------------------------------------------- identify.ppp <- function(x, ...) { verifyclass(x, "ppp") if(dev.cur() == 1 && interactive()) { eval(substitute(plot(X), list(X=substitute(x)))) } id <- identify(x$x, x$y, ...) if(!is.marked(x)) return(id) marks <- as.data.frame(x)[id, -(1:2)] out <- cbind(data.frame(id=id), marks) row.names(out) <- NULL return(out) } rebound <- function(x, rect) { UseMethod("rebound") } rebound.ppp <- function(x, rect) { verifyclass(x, "ppp") x$window <- rebound.owin(x$window, rect) return(x) } as.data.frame.ppp <- function(x, row.names=NULL, ...) { df <- data.frame(x=x$x, y=x$y, row.names=row.names) marx <- marks(x, dfok=TRUE) if(is.null(marx)) return(df) if(is.data.frame(marx)) df <- cbind(df, marx) else df <- data.frame(df, marks=marx) return(df) } is.empty.ppp <- function(x) { return(x$n == 0) } npoints <- function(x) { UseMethod("npoints") } nobjects <- function(x) { UseMethod("nobjects") } nobjects.ppp <- npoints.ppp <- function(x) { x$n } domain.ppp <- Window.ppp <- function(X, ...) { as.owin(X) } "Window<-.ppp" <- function(X, ..., value) { verifyclass(value, "owin") return(X[value]) } "Frame<-.ppp" <- function(X, value) { Frame(Window(X)) <- value return(X) } #' convert any appropriate subset index for any kind of point pattern #' to a logical vector ppsubset <- function(X, I, Iname, fatal=FALSE) { ## 'I' could be a window or logical image if(is.im(I)) I <- solutionset(I) if((is.ppp(X) || is.lpp(X)) && is.owin(I)) { I <- inside.owin(X, w=I) return(I) } if((is.pp3(X) && inherits(I, "box3")) || (is.ppx(X) && inherits(I, "boxx"))) { I <- inside.boxx(X, w=I) return(I) } ## 'I' could be a function to be applied to X if(is.function(I)) { I <- I(X) if(!is.vector(I)) { if(missing(Iname)) Iname <- short.deparse(substitute(I)) whinge <- paste("Function", sQuote(Iname), "did not return a vector") if(fatal) stop(whinge, call.=FALSE) warning(whinge, call.=FALSE) return(NULL) } } ## 'I' is now a subset index: convert to logical I <- grokIndexVector(I, npoints(X))$strict$lo if(anyNA(I)) { #' illegal entries if(missing(Iname)) Iname <- short.deparse(substitute(I)) whinge <- paste("Indices in", sQuote(Iname), "exceed array limits") if(fatal) stop(whinge, call.=FALSE) warning(whinge, call.=FALSE) return(NULL) } return(I) } spatstat.geom/R/flaky.R0000644000176200001440000000051514611065351014500 0ustar liggesusers#' #' flaky.R #' #' Code to defend against crashes in calls to external packages #' #' $Revision: 1.1 $ $Date: 2023/07/09 04:13:48 $ #' safeDevCapabilities <- function() { a <- try(dev.capabilities()) if(!inherits(a, "try-error")) return(a) warning("dev.capabilities() caused an error!", call.=FALSE) return(NULL) } spatstat.geom/R/dummy.R0000644000176200001440000002765314611065351014541 0ustar liggesusers# # dummy.S # # Utilities for generating patterns of dummy points # # $Revision: 5.32 $ $Date: 2018/09/28 05:11:55 $ # # corners() corners of window # gridcenters() points of a rectangular grid # stratrand() random points in each tile of a rectangular grid # spokes() Rolf's 'spokes' arrangement # # concatxy() concatenate any lists of x, y coordinates # # default.dummy() Default action to create a dummy pattern # corners <- function(window) { window <- as.owin(window) x <- window$xrange[c(1L,2L,1L,2L)] y <- window$yrange[c(1L,1L,2L,2L)] return(list(x=x, y=y)) } gridcenters <- gridcentres <- function(window, nx, ny) { window <- as.owin(window) xr <- window$xrange yr <- window$yrange x <- seq(from=xr[1L], to=xr[2L], length.out = 2L * nx + 1L)[2L * (1:nx)] y <- seq(from=yr[1L], to=yr[2L], length.out = 2L * ny + 1L)[2L * (1:ny)] x <- rep.int(x, ny) y <- rep.int(y, rep.int(nx, ny)) return(list(x=x, y=y)) } stratrand <- function(window,nx,ny, k=1) { # divide window into an nx * ny grid of tiles # and place k points at random in each tile window <- as.owin(window) wide <- diff(window$xrange)/nx high <- diff(window$yrange)/ny cent <- gridcentres(window, nx, ny) cx <- rep.int(cent$x, k) cy <- rep.int(cent$y, k) n <- nx * ny * k x <- cx + runif(n, min = -wide/2, max = wide/2) y <- cy + runif(n, min = -high/2, max = high/2) return(list(x=x,y=y)) } tilecentroids <- function (W, nx, ny) { W <- as.owin(W) if(W$type == "rectangle") return(gridcentres(W, nx, ny)) else { # approximate W <- as.mask(W) rxy <- rasterxy.mask(W, drop=TRUE) xx <- rxy$x yy <- rxy$y pid <- gridindex(xx,yy,W$xrange,W$yrange,nx,nx)$index x <- tapply(xx,pid,mean) y <- tapply(yy,pid,mean) return(list(x=x,y=y)) } } cellmiddles <- local({ # auxiliary middle <- function(v) { n <- length(v); mid <- ceiling(n/2); v[mid]} dcut <- function(x, nx, xrange) { dx <- diff(xrange)/nx fx <- ((x - xrange[1L])/dx) %% 1 bx <- dx * pmin(fx, 1-fx) bx } # main cellmiddles <- function (W, nx, ny, npix=NULL, distances=FALSE) { if(W$type == "rectangle") return(gridcentres(W, nx, ny)) # pixel approximation to window # This matches the pixel approximation used to compute tile areas # and ensures that dummy points are generated only inside those tiles # that have nonzero digital area M <- as.mask(W, dimyx=rev(npix)) xx <- as.vector(rasterx.mask(M, drop=TRUE)) yy <- as.vector(rastery.mask(M, drop=TRUE)) pid <- gridindex(xx,yy,W$xrange,W$yrange,nx,ny)$index # compute tile centroids xmid <- tapply(xx, pid, mean) ymid <- tapply(yy, pid, mean) # check whether they are inside window ok <- inside.owin(xmid, ymid, W) if(all(ok)) return(list(x=xmid, y=ymid)) # some problem tiles bad <- rep.int(TRUE, nx * ny) bad[as.integer(names(xmid))] <- !ok badpid <- bad[pid] if(!distances) { midpix <- tapply(seq_along(pid)[badpid], pid[badpid], middle) } else { # find 'middle' points using boundary distances Dlines <- im(outer(dcut(M$yrow,ny,M$yrange), dcut(M$xcol,nx,M$xrange), "pmin"), M$xcol, M$yrow, M$xrange, M$yrange) Dbdry <- bdist.pixels(M) Dtile <- eval.im(pmin(Dlines, Dbdry)) dtile <- as.vector(Dtile[M]) df <- data.frame(dtile=dtile, id=seq_along(dtile))[badpid, , drop=FALSE] midpix <- by(df, pid[badpid], midpixid) } xmid[!ok] <- xx[midpix] ymid[!ok] <- yy[midpix] return(list(x=xmid,y=ymid)) } midpixid <- function(z) { z$id[which.max(z$dtile)] } cellmiddles }) spokes <- function(x, y, nrad = 3, nper = 3, fctr = 1.5, Mdefault=1) { # # Rolf Turner's "spokes" arrangement # # Places dummy points on radii of circles # emanating from each data point x[i], y[i] # # nrad: number of radii from each data point # nper: number of dummy points per radius # fctr: length of largest radius = fctr * M # where M is mean nearest neighbour distance in data # pat <- inherits(x,"ppp") if(pat) w <- x$w if(checkfields(x,c("x","y"))) { y <- x$y x <- x$x } M <- if(length(x) > 1) mean(nndist(x,y)) else Mdefault lrad <- fctr * M / nper theta <- 2 * pi * (1:nrad)/nrad cs <- cos(theta) sn <- sin(theta) xt <- lrad * as.vector((1:nper) %o% cs) yt <- lrad * as.vector((1:nper) %o% sn) xd <- as.vector(outer(x, xt, "+")) yd <- as.vector(outer(y, yt, "+")) tmp <- list(x = xd, y = yd) if(pat) return(as.ppp(tmp,W=w)[w]) else return(tmp) } # concatenate any number of list(x,y) into a list(x,y) concatxy <- function(...) { x <- unlist(lapply(list(...), getElement, name="x")) y <- unlist(lapply(list(...), getElement, name="y")) if(length(x) != length(y)) stop("Internal error: lengths of x and y unequal") return(list(x=x,y=y)) } #------------------------------------------------------------ default.dummy <- function(X, nd=NULL, random=FALSE, ntile=NULL, npix = NULL, quasi=FALSE, ..., eps=NULL, verbose=FALSE) { # default action to create dummy points. # regular grid of nd[1] * nd[2] points # plus corner points of window frame, # all clipped to window. orig <- list(nd=nd, eps=eps, ntile=ntile, npix=npix) orig <- orig[!sapply(orig, is.null)] # X <- as.ppp(X) win <- X$window # # # default dimensions a <- default.n.tiling(X, nd=nd, ntile=ntile, npix=npix, eps=eps, random=random, quasi=quasi, verbose=verbose) nd <- a$nd ntile <- a$ntile npix <- a$npix periodsample <- !quasi && !random && is.mask(win) && all(nd %% win$dim == 0) # make dummy points dummy <- if(quasi) rQuasi(prod(nd), as.rectangle(win)) else if(random) stratrand(win, nd[1L], nd[2L], 1) else cellmiddles(win, nd[1L], nd[2L], npix) dummy <- as.ppp(dummy, win, check=FALSE) # restrict to window if(!is.rectangle(win) && !periodsample) dummy <- dummy[win] # corner points corn <- as.ppp(corners(win), win, check=FALSE) corn <- corn[win] dummy <- superimpose(dummy, corn, W=win, check=FALSE) if(dummy$n == 0) stop("None of the dummy points lies inside the window") # pass parameters for computing weights attr(dummy, "weight.parameters") <- append(list(...), list(ntile=ntile, verbose=verbose, npix=npix)) # record parameters used to create dummy locations attr(dummy, "dummy.parameters") <- list(nd=nd, random=random, quasi=quasi, verbose=verbose, orig=orig) return(dummy) } # Criteria: # for rectangular windows, # R1. nd >= ntile # for non-rectangular windows, # R2. nd should be a multiple of ntile # R3. each dummy point is also a pixel of the npix grid # R4. npix should ideally be a multiple of nd, for speed # R5. npix should be large, for accuracy # R6. npix should not be too large, for speed # R7. if the window is a mask, npix should ideally be # a multiple of the mask array dimensions, for speed. # default.n.tiling <- local({ # auxiliary ensure2print <- function(x, verbose=TRUE, blah="user specified") { xname <- short.deparse(substitute(x)) x <- ensure2vector(x) if(verbose) cat(paste(blah, xname, "=", x[1L], "*", x[2L], "\n")) x } minmultiple <- function(n, lo, hi) { if(lo > hi) { temp <- hi hi <- lo lo <- temp } if(n > hi) return(hi) m <- n * (floor(lo/n):ceiling(hi/n)) m <- m[m >= n & m >= lo & m <= hi] if(length(m) > 0) min(m) else hi } mindivisor <- function(N, lo, Nbig) { d <- divisors(N) ok <- (d >= lo) if(any(ok)) return(min(d[ok])) m <- floor(Nbig/N) d <- unlist(lapply(as.list(seq_len(m) * N), divisors)) d <- sortunique(d) ok <- (d >= lo) if(any(ok)) return(min(d[ok])) return(Nbig) } min2mul <- function(n, lo, hi) c(minmultiple(n[1L], lo[1L], hi[1L]), minmultiple(n[2L], lo[2L], hi[2L])) min2div <- function(N, lo, Nbig) c(mindivisor(N[1L], lo[1L], Nbig[1L]), mindivisor(N[2L], lo[2L], Nbig[2L])) maxdiv <- function(n, k=1) { if(length(n) > 1L) return(c(maxdiv(n[1L], k), maxdiv(n[2L], k))) ## k-th largest divisor other than n d <- divisors(n) m <- length(d) ans <- if(m == 2L) n else if(m < 2+k) d[2L] else d[m-k] return(ans) } # main default.n.tiling <- function(X, nd=NULL, ntile=NULL, npix=NULL, eps=NULL, random=FALSE, quasi=FALSE, verbose=TRUE) { # computes dimensions of rectangular grids of # - dummy points (nd) (eps) # - tiles for grid weights (ntile) # - pixels for approximating area (npix) # for data pattern X. # verifyclass(X, "ppp") win <- X$window pixels <- (win$type != "rectangle") if(nd.given <- !is.null(nd)) nd <- ensure2print(nd, verbose) if(ntile.given <- !is.null(ntile)) ntile <- ensure2print(ntile, verbose) if(npix.given <- !is.null(npix)) npix <- ensure2print(npix, verbose) if(pixels) sonpixel <- rev(ensure2print(spatstat.options("npixel"), verbose, "")) ndummy.min <- ensure2print(spatstat.options("ndummy.min"), verbose, "") ndminX <- pmax(ndummy.min, 10 * ceiling(2 * sqrt(X$n)/10)) ndminX <- ensure2vector(ndminX) if(!is.null(eps)) { eps <- ensure2print(eps, verbose) Xbox <- as.rectangle(as.owin(X)) sides <- with(Xbox, c(diff(xrange), diff(yrange))) ndminX <- pmax(ndminX, ceiling(sides/eps)) } # range of acceptable values for npix if(npix.given) Nmin <- Nmax <- npix else switch(win$type, rectangle = { Nmin <- ensure2vector(X$n) Nmax <- Inf }, polygonal = { Nmin <- sonpixel Nmax <- 4 * sonpixel }, mask={ nmask <- rev(win$dim) Nmin <- nmask Nmax <- pmax(2 * nmask, 4 * sonpixel) }) # determine values of nd and ntile if(nd.given && !ntile.given) { # ntile must be a divisor of nd if(any(nd > Nmax)) warning("number of dummy points nd exceeds maximum pixel dimensions") ntile <- min2div(nd, ndminX, nd) } else if(!nd.given && ntile.given) { # nd must be a multiple of ntile nd <- min2mul(ntile, ndminX, Nmin) if(any(nd >= Nmin)) nd <- ntile } else if(!nd.given && !ntile.given) { if(!pixels) { nd <- ntile <- ensure2vector(ndminX) if(verbose) cat(paste("nd and ntile default to", nd[1L], "*", nd[2L], "\n")) } else { # find suitable divisors of the number of pixels nd <- ntile <- min2div(Nmin, ndminX, Nmax) if(any(nd >= Nmin)) { # none suitable if(verbose) cat("No suitable divisor of pixel dimensions\n") nd <- ntile <- ndminX } } } else { # both nd, ntile were given if(any(ntile > nd)) warning("the number of tiles (ntile) exceeds the number of dummy points (nd)") } if(!ntile.given && quasi) { if(verbose) cat("Adjusting ntile because quasi=TRUE\n") ntile <- maxdiv(ntile, if(pixels) 2L else 1L) } if(!npix.given && pixels) npix <- min2mul(nd, Nmin, Nmax) if(verbose) { if(!quasi) cat(paste("dummy points:", paste0(if(random) "stratified random in" else NULL, "grid"), nd[1L], "x", nd[2L], "\n")) else cat(paste("dummy points:", nd[1L], "x", nd[2L], "=", prod(nd), "quasirandom points\n")) cat(paste("weighting tiles", ntile[1L], "x", ntile[2L], "\n")) if(pixels) cat(paste("pixel grid", npix[1L], "x", npix[2L], "\n")) } if(pixels) return(list(nd=nd, ntile=ntile, npix=npix)) else return(list(nd=nd, ntile=ntile, npix=npix)) } default.n.tiling }) spatstat.geom/R/simplepanel.R0000644000176200001440000001720314612336204015704 0ustar liggesusers# # simplepanel.R # # A simple, robust point & click interface # used in rmh visual debugger. # # $Revision: 1.20 $ $Date: 2024/04/25 01:23:23 $ # simplepanel <- function(title, B, boxes, clicks, redraws=NULL, exit=NULL, env) { stopifnot(is.rectangle(B)) stopifnot(is.list(boxes)) if(!all(unlist(lapply(boxes, is.rectangle)))) stop("some of the boxes are not rectangles") if(!all(unlist(lapply(boxes, is.subset.owin, B=B)))) stop("Some boxes do not lie inside the bounding box B") stopifnot(is.list(clicks) && length(clicks) == length(boxes)) if(!all(unlist(lapply(clicks, is.function)))) stop("clicks must be a list of functions") if(is.null(redraws)) { redraws <- rep.int(list(dflt.redraw), length(boxes)) } else { stopifnot(is.list(redraws) && length(redraws) == length(boxes)) if(any(isnul <- unlist(lapply(redraws, is.null)))) redraws[isnul] <- rep.int(list(dflt.redraw), sum(isnul)) if(!all(unlist(lapply(redraws, is.function)))) stop("redraws must be a list of functions") } if(is.null(exit)) { exit <- function(...) { NULL} } else stopifnot(is.function(exit)) stopifnot(is.environment(env)) n <- length(boxes) bnames <- names(boxes) %orifnull% rep("", n) cnames <- names(clicks) %orifnull% rep("", n) dnames <- paste("Button", seq_len(n)) nama <- ifelse(nzchar(bnames), bnames, ifelse(nzchar(cnames), cnames, dnames)) out <- list(title=title, B=B, nama=nama, boxes=boxes, clicks=clicks, redraws=redraws, exit=exit, env=env) class(out) <- c("simplepanel", class(out)) return(out) } grow.simplepanel <- function(P, side=c("right","left","top","bottom"), len=NULL, new.clicks, new.redraws=NULL, ..., aspect) { verifyclass(P, "simplepanel") side <- match.arg(side) stopifnot(is.list(new.clicks)) if(!all(unlist(lapply(new.clicks, is.function)))) stop("new.clicks must be a list of functions") if(is.null(new.redraws)) { new.redraws <- rep.int(list(dflt.redraw), length(new.clicks)) } else { stopifnot(is.list(new.redraws) && length(new.redraws) == length(new.clicks)) if(any(isnul <- sapply(new.redraws, is.null))) new.redraws[isnul] <- rep.int(list(dflt.redraw), sum(isnul)) if(!all(unlist(lapply(new.redraws, is.function)))) stop("new.redraws must be a list of functions") } if(missing(aspect) || is.null(aspect)) { # determine aspect ratio from length of longest text string n <- length(new.clicks) nama <- names(new.clicks) if(sum(nzchar(nama)) != n) nama <- names(new.redraws) if(sum(nzchar(nama)) != n) nama <- paste("Box", seq_len(n)) aspect <- 3/max(4, nchar(nama)) } B <- P$B n <- length(new.clicks) switch(side, right={ new.width <- if(!is.null(len)) len else sidelengths(B)[1]/2 extraspace <- owinInternalRect(B$xrange[2] + c(0, new.width), B$yrange) new.boxes <- layout.boxes(extraspace, n, ..., aspect=aspect) }, left={ new.width <- if(!is.null(len)) len else sidelengths(B)[1]/2 extraspace <- owinInternalRect(B$xrange[1] - c(new.width, 0), B$yrange) new.boxes <- layout.boxes(extraspace, n, ..., aspect=aspect) }, top={ new.height <- if(!is.null(len)) len else sidelengths(B)[2]/2 extraspace <- owinInternalRect(B$xrange, B$yrange[2] + c(0, new.height)) new.boxes <- layout.boxes(extraspace, n, ..., aspect=aspect, horizontal=TRUE) }, bottom={ new.height <- if(!is.null(len)) len else sidelengths(B)[2]/2 extraspace <- owinInternalRect(B$xrange, B$yrange[1] - c(new.height, 0)) new.boxes <- layout.boxes(extraspace, n, ..., aspect=aspect, horizontal=TRUE) }) with(P, simplepanel(title, boundingbox(B, extraspace), append(boxes, new.boxes), append(clicks, new.clicks), append(redraws, new.redraws), exit, env)) } redraw.simplepanel <- function(P, verbose=FALSE) { verifyclass(P, "simplepanel") if(verbose) cat("Redrawing entire panel\n") with(P, { # ntitle <- sum(nzchar(title)) plot(B, type="n", main=title) for(j in seq_along(nama)) (redraws[[j]])(boxes[[j]], nama[j], env) }) dev.flush() invisible(NULL) } clear.simplepanel <- function(P) { verifyclass(P, "simplepanel") plot(P$B, main="") dev.flush() invisible(NULL) } run.simplepanel <- function(P, popup=TRUE, verbose=FALSE) { verifyclass(P, "simplepanel") if(popup) dev.new() ntitle <- sum(nzchar(P$title)) opa <- par(mar=c(0,0,ntitle+0.2,0),ask=FALSE) if(!popup) on.exit(par(opa)) with(P, { # interaction loop more <- TRUE while(more) { redraw.simplepanel(P, verbose=verbose) xy <- spatstatLocator(1) if(is.null(xy) || length(xy$x) == 0) { if(verbose) cat("No (x,y) coordinates\n") break } found <- FALSE for(j in seq_along(boxes)) { if(inside.owin(xy$x, xy$y, boxes[[j]])) { found <- TRUE if(verbose) cat(paste("Caught click on", sQuote(nama[j]), "\n")) more <- (clicks[[j]])(env, xy) if(!is.logical(more) || length(more) != 1) { warning(paste("Click function for", sQuote(nama[j]), "did not return TRUE/FALSE")) more <- FALSE } if(verbose) cat(if(more) "Continuing\n" else "Terminating\n") break } } if(verbose && !found) cat(paste("Coordinates", paren(paste(xy, collapse=",")), "not matched to any box\n")) } }) if(verbose) cat("Calling exit function\n") rslt <- with(P, exit(env)) # revert to original graphics parameters par(opa) # close popup window? if(popup) dev.off() # return value of 'exit' function return(rslt) } layout.boxes <- function(B, n, horizontal=FALSE, aspect=0.5, usefrac=0.9){ # make n boxes in B stopifnot(is.rectangle(B)) stopifnot(n > 0) width <- sidelengths(B)[1] height <- sidelengths(B)[2] if(is.finite(aspect) && aspect > 0) { recip.aspect <- 1/aspect } else { aspect <- Inf recip.aspect <- Inf } if(!horizontal) { heightshare <- height/n useheight <- min(heightshare * usefrac, width * aspect) usewidth <- min(width * usefrac, useheight * recip.aspect) lostwidth <- width - usewidth lostheightshare <- heightshare - useheight template <- owinInternalRect(c(0, usewidth), c(0, useheight)) boxes <- list() boxes[[1]] <- shift(template, c(B$xrange[1]+lostwidth/2, B$yrange[1] + lostheightshare/2)) if(n > 1) for(j in 2:n) boxes[[j]] <- shift(boxes[[j-1]], c(0, heightshare)) } else { boxes <- layout.boxes(flipxy(B), n, horizontal=FALSE, aspect=recip.aspect, usefrac=usefrac) boxes <- lapply(boxes, flipxy) } return(boxes) } # default redraw function for control buttons dflt.redraw <- function(button, name, env) { plot(button, add=TRUE, border="pink") text(centroid.owin(button), labels=name) return(TRUE) } print.simplepanel <- function(x, ...) { nama <- x$nama cat("simplepanel object\n") cat(paste("\tTitle:", sQuote(x$title), "\n")) cat("\tPanel names:") for(i in seq_along(nama)) { if(i %% 6 == 1) cat("\n\t") cat(paste0(sQuote(nama[i]), " ")) } cat("\n") return(invisible(NULL)) } spatstat.geom/R/closepairs.R0000644000176200001440000006513214611065351015544 0ustar liggesusers# # closepairs.R # # $Revision: 1.54 $ $Date: 2022/06/15 01:35:50 $ # # simply extract the r-close pairs from a dataset # # Less memory-hungry for large patterns # closepairs <- function(X, rmax, ...) { UseMethod("closepairs") } closepairs.ppp <- function(X, rmax, twice=TRUE, what=c("all", "indices", "ijd"), distinct=TRUE, neat=TRUE, periodic=FALSE, ...) { verifyclass(X, "ppp") what <- match.arg(what) stopifnot(is.numeric(rmax) && length(rmax) == 1L) stopifnot(is.finite(rmax)) stopifnot(rmax >= 0) ordered <- list(...)$ordered if(missing(twice) && !is.null(ordered)) { warning("Obsolete argument 'ordered' has been replaced by 'twice'") twice <- ordered } if(periodic && !is.rectangle(Window(X))) warning("Periodic edge correction applied in non-rectangular window", call.=FALSE) npts <- npoints(X) null.answer <- switch(what, all = { list(i=integer(0), j=integer(0), xi=numeric(0), yi=numeric(0), xj=numeric(0), yj=numeric(0), dx=numeric(0), dy=numeric(0), d=numeric(0)) }, indices = { list(i=integer(0), j=integer(0)) }, ijd = { list(i=integer(0), j=integer(0), d=numeric(0)) }) if(npts == 0) return(null.answer) ## sort points by increasing x coordinate if(!periodic) { oo <- fave.order(X$x) Xsort <- X[oo] } ## First make an OVERESTIMATE of the number of unordered pairs nsize <- list(...)$nsize # secret option to test memory overflow code if(!is.null(nsize)) { splat("Using nsize =", nsize) } else { #' normal usage #' calculate a conservative estimate of the number of pairs npairs <- as.double(npts)^2 if(npairs <= 1024) { nsize <- 1024 } else { catchfraction <- pi * (rmax^2)/area(Frame(X)) nsize <- ceiling(2 * catchfraction * npairs) nsize <- min(nsize, npairs) nsize <- max(1024, nsize) if(nsize > .Machine$integer.max) { warning( "Estimated number of close pairs exceeds maximum possible integer", call.=FALSE) nsize <- .Machine$integer.max } } } ## Now extract pairs if(periodic) { ## special algorithm for periodic distance got.twice <- TRUE x <- X$x y <- X$y r <- rmax p <- sidelengths(Frame(X)) ng <- nsize storage.mode(x) <- "double" storage.mode(y) <- "double" storage.mode(r) <- "double" storage.mode(p) <- "double" storage.mode(ng) <- "integer" z <- .Call(SG_closePpair, xx=x, yy=y, pp=p, rr=r, nguess=ng, PACKAGE="spatstat.geom") i <- z[[1L]] j <- z[[2L]] d <- z[[3L]] if(what == "all") { xi <- x[i] yi <- y[i] xj <- x[j] yj <- y[j] dx <- xj - xi dy <- yj - yi } } else if(spatstat.options("closepairs.newcode")) { # ------------------- use new faster code --------------------- # fast algorithms collect each distinct pair only once got.twice <- FALSE ng <- nsize # x <- Xsort$x y <- Xsort$y r <- rmax storage.mode(x) <- "double" storage.mode(y) <- "double" storage.mode(r) <- "double" storage.mode(ng) <- "integer" switch(what, all = { z <- .Call(SG_Vclosepairs, xx=x, yy=y, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 9) stop("Internal error: incorrect format returned from Vclosepairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] xi <- z[[3L]] yi <- z[[4L]] xj <- z[[5L]] yj <- z[[6L]] dx <- z[[7L]] dy <- z[[8L]] d <- z[[9L]] }, indices = { z <- .Call(SG_VcloseIJpairs, xx=x, yy=y, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 2) stop("Internal error: incorrect format returned from VcloseIJpairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] }, ijd = { z <- .Call(SG_VcloseIJDpairs, xx=x, yy=y, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 3) stop("Internal error: incorrect format returned from VcloseIJDpairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] d <- z[[3L]] }) } else if(spatstat.options("closepairs.altcode")) { #' experimental alternative code got.twice <- FALSE ng <- nsize # x <- Xsort$x y <- Xsort$y r <- rmax storage.mode(x) <- "double" storage.mode(y) <- "double" storage.mode(r) <- "double" storage.mode(ng) <- "integer" switch(what, all = { z <- .Call(SG_altVclosepairs, xx=x, yy=y, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 9) stop("Internal error: incorrect format returned from altVclosepairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] xi <- z[[3L]] yi <- z[[4L]] xj <- z[[5L]] yj <- z[[6L]] dx <- z[[7L]] dy <- z[[8L]] d <- z[[9L]] }, indices = { z <- .Call(SG_altVcloseIJpairs, xx=x, yy=y, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 2) stop("Internal error: incorrect format returned from altVcloseIJpairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] }, ijd = { z <- .Call(SG_altVcloseIJDpairs, xx=x, yy=y, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 3) stop("Internal error: incorrect format returned from altVcloseIJDpairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] d <- z[[3L]] }) } else { # ------------------- use older code -------------------------- if(!distinct) { ii <- seq_len(npts) xx <- X$x yy <- X$y zeroes <- rep(0, npts) null.answer <- switch(what, all = { list(i=ii, j=ii, xi=xx, yi=yy, xj=xx, yj=yy, dx=zeroes, dy=zeroes, d=zeroes) }, indices = { list(i=ii, j=ii) }, ijd = { list(i=ii, j=ii, d=zeroes) }) } got.twice <- TRUE nsize <- as.integer(min(as.double(nsize) * 2, as.double(.Machine$integer.max))) z <- .C(SG_Fclosepairs, nxy=as.integer(npts), x=as.double(Xsort$x), y=as.double(Xsort$y), r=as.double(rmax), noutmax=as.integer(nsize), nout=as.integer(integer(1L)), iout=as.integer(integer(nsize)), jout=as.integer(integer(nsize)), xiout=as.double(numeric(nsize)), yiout=as.double(numeric(nsize)), xjout=as.double(numeric(nsize)), yjout=as.double(numeric(nsize)), dxout=as.double(numeric(nsize)), dyout=as.double(numeric(nsize)), dout=as.double(numeric(nsize)), status=as.integer(integer(1L)), PACKAGE="spatstat.geom") if(z$status != 0) { # Guess was insufficient # Obtain an OVERCOUNT of the number of pairs # (to work around gcc bug #323) rmaxplus <- 1.25 * rmax nsize <- .C(SG_paircount, nxy=as.integer(npts), x=as.double(Xsort$x), y=as.double(Xsort$y), rmaxi=as.double(rmaxplus), count=as.integer(integer(1L)), PACKAGE="spatstat.geom")$count if(nsize <= 0) return(null.answer) # add a bit more for safety nsize <- ceiling(1.1 * nsize) + 2 * npts # now extract points z <- .C(SG_Fclosepairs, nxy=as.integer(npts), x=as.double(Xsort$x), y=as.double(Xsort$y), r=as.double(rmax), noutmax=as.integer(nsize), nout=as.integer(integer(1L)), iout=as.integer(integer(nsize)), jout=as.integer(integer(nsize)), xiout=as.double(numeric(nsize)), yiout=as.double(numeric(nsize)), xjout=as.double(numeric(nsize)), yjout=as.double(numeric(nsize)), dxout=as.double(numeric(nsize)), dyout=as.double(numeric(nsize)), dout=as.double(numeric(nsize)), status=as.integer(integer(1L)), PACKAGE="spatstat.geom") if(z$status != 0) stop(paste("Internal error: C routine complains that insufficient space was allocated:", nsize)) } # trim vectors to the length indicated npairs <- z$nout if(npairs <= 0) return(null.answer) actual <- seq_len(npairs) i <- z$iout[actual] # sic j <- z$jout[actual] switch(what, indices={}, all={ xi <- z$xiout[actual] yi <- z$yiout[actual] xj <- z$xjout[actual] yj <- z$yjout[actual] dx <- z$dxout[actual] dy <- z$dyout[actual] d <- z$dout[actual] }, ijd = { d <- z$dout[actual] }) # ------------------- end code switch ------------------------ } if(!periodic) { ## convert i,j indices to original sequence i <- oo[i] j <- oo[j] } if(twice) { ## both (i, j) and (j, i) should be returned if(!got.twice) { ## duplication required iold <- i jold <- j i <- c(iold, jold) j <- c(jold, iold) switch(what, indices = { }, ijd = { d <- rep(d, 2) }, all = { xinew <- c(xi, xj) yinew <- c(yi, yj) xjnew <- c(xj, xi) yjnew <- c(yj, yi) xi <- xinew yi <- yinew xj <- xjnew yj <- yjnew dx <- c(dx, -dx) dy <- c(dy, -dy) d <- rep(d, 2) }) } } else { ## only one of (i, j) and (j, i) should be returned if(got.twice) { ## remove duplication ok <- (i < j) i <- i[ok] j <- j[ok] switch(what, indices = { }, all = { xi <- xi[ok] yi <- yi[ok] xj <- xj[ok] yj <- yj[ok] dx <- dx[ok] dy <- dy[ok] d <- d[ok] }, ijd = { d <- d[ok] }) } else if(neat) { ## enforce i < j swap <- (i > j) tmp <- i[swap] i[swap] <- j[swap] j[swap] <- tmp if(what == "all") { xinew <- ifelse(swap, xj, xi) yinew <- ifelse(swap, yj, yi) xjnew <- ifelse(swap, xi, xj) yjnew <- ifelse(swap, yi, yj) xi <- xinew yi <- yinew xj <- xjnew yj <- yjnew dx[swap] <- -dx[swap] dy[swap] <- -dy[swap] } } ## otherwise no action required } ## add pairs of identical points? if(!distinct) { ii <- seq_len(npts) xx <- X$x yy <- X$y zeroes <- rep(0, npts) i <- c(i, ii) j <- c(j, ii) switch(what, ijd={ d <- c(d, zeroes) }, all = { xi <- c(xi, xx) yi <- c(yi, yy) xj <- c(xj, xx) yj <- c(yj, yy) dx <- c(dx, zeroes) dy <- c(dy, zeroes) d <- c(d, zeroes) }) } ## done switch(what, all = { answer <- list(i=i, j=j, xi=xi, yi=yi, xj=xj, yj=yj, dx=dx, dy=dy, d=d) }, indices = { answer <- list(i = i, j = j) }, ijd = { answer <- list(i=i, j=j, d=d) }) return(answer) } ####################### crosspairs <- function(X, Y, rmax, ...) { UseMethod("crosspairs") } crosspairs.ppp <- function(X, Y, rmax, what=c("all", "indices", "ijd"), periodic=FALSE, ..., iX=NULL, iY=NULL) { verifyclass(X, "ppp") verifyclass(Y, "ppp") what <- match.arg(what) stopifnot(is.numeric(rmax) && length(rmax) == 1L && rmax >= 0) null.answer <- switch(what, all = { list(i=integer(0), j=integer(0), xi=numeric(0), yi=numeric(0), xj=numeric(0), yj=numeric(0), dx=numeric(0), dy=numeric(0), d=numeric(0)) }, indices = { list(i=integer(0), j=integer(0)) }, ijd = { list(i=integer(0), j=integer(0), d=numeric(0)) }) nX <- npoints(X) nY <- npoints(Y) if(nX == 0 || nY == 0) return(null.answer) nXY <- as.double(nX) * as.double(nY) if(periodic) { ## ............... Periodic distance .................. if(!is.rectangle(Window(Y))) warning("Periodic edge correction applied in non-rectangular window", call.=FALSE) ## Overestimate the number of pairs if(nXY <= 1024) { nsize <- 1024 } else { catchfraction <- pi * (rmax^2)/area(Frame(Y)) nsize <- ceiling(2 * catchfraction * nXY) nsize <- min(nsize, nXY) nsize <- max(1024, nsize) if(nsize > .Machine$integer.max) { warning( "Estimated number of close pairs exceeds maximum possible integer", call.=FALSE) nsize <- .Machine$integer.max } } # .Call Xx <- X$x Xy <- X$y Yx <- Y$x Yy <- Y$y per <- sidelengths(Frame(Y)) r <- rmax ng <- nsize storage.mode(Xx) <- storage.mode(Xy) <- "double" storage.mode(Yx) <- storage.mode(Yy) <- "double" storage.mode(per) <- storage.mode(r) <- "double" storage.mode(ng) <- "integer" z <- .Call(SG_crossPpair, xxA=Xx, yyA=Xy, xxB=Yx, yyB=Yy, pp=per, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 3) stop("Internal error: incorrect format returned from crossPpair") i <- z[[1L]] # NB no increment required j <- z[[2L]] d <- z[[3L]] answer <- switch(what, indices = list(i=i, j=j), ijd = list(i=i, j=j, d=d), all = { xi <- Xx[i] yi <- Xy[i] xj <- Yx[j] yj <- Yy[j] dx <- xj-xi dy <- yj-yi list(i=i, j=j, xi=xi, yi=yi, xj=xj, yj=yj, dx=dx, dy=dy, d=d) }) if(!is.null(iX) && !is.null(iY)) answer <- remove.identical.pairs(answer, iX, iY) return(answer) } ## .......... Euclidean distance ....................... ## order patterns by increasing x coordinate ooX <- fave.order(X$x) Xsort <- X[ooX] ooY <- fave.order(Y$x) Ysort <- Y[ooY] if(spatstat.options("crosspairs.newcode")) { ## ------------------- use new faster code --------------------- ## First (over)estimate the number of pairs nXY <- as.double(nX) * as.double(nY) if(nXY <= 1024) { nsize <- 1024 } else { catchfraction <- pi * (rmax^2)/area(Frame(Y)) nsize <- ceiling(2 * catchfraction * nXY) nsize <- min(nsize, nXY) nsize <- max(1024L, nsize) if(nsize > .Machine$integer.max) { warning( "Estimated number of close pairs exceeds maximum possible integer", call.=FALSE) nsize <- .Machine$integer.max } } # .Call Xx <- Xsort$x Xy <- Xsort$y Yx <- Ysort$x Yy <- Ysort$y r <- rmax ng <- nsize storage.mode(Xx) <- storage.mode(Xy) <- "double" storage.mode(Yx) <- storage.mode(Yy) <- "double" storage.mode(r) <- "double" storage.mode(ng) <- "integer" switch(what, all = { z <- .Call(SG_Vcrosspairs, xx1=Xx, yy1=Xy, xx2=Yx, yy2=Yy, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 9) stop("Internal error: incorrect format returned from Vcrosspairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] xi <- z[[3L]] yi <- z[[4L]] xj <- z[[5L]] yj <- z[[6L]] dx <- z[[7L]] dy <- z[[8L]] d <- z[[9L]] }, indices = { z <- .Call(SG_VcrossIJpairs, xx1=Xx, yy1=Xy, xx2=Yx, yy2=Yy, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 2) stop("Internal error: incorrect format returned from VcrossIJpairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] }, ijd = { z <- .Call(SG_VcrossIJDpairs, xx1=Xx, yy1=Xy, xx2=Yx, yy2=Yy, rr=r, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 3) stop("Internal error: incorrect format returned from VcrossIJDpairs") i <- z[[1L]] # NB no increment required j <- z[[2L]] d <- z[[3L]] }) } else { # Older code # obtain upper estimate of number of pairs # (to work around gcc bug 323) rmaxplus <- 1.25 * rmax nsize <- .C(SG_crosscount, nn1=as.integer(X$n), x1=as.double(Xsort$x), y1=as.double(Xsort$y), nn2=as.integer(Ysort$n), x2=as.double(Ysort$x), y2=as.double(Ysort$y), rmaxi=as.double(rmaxplus), count=as.integer(integer(1L)), PACKAGE="spatstat.geom")$count if(nsize <= 0) return(null.answer) # allow slightly more space to work around gcc bug #323 nsize <- ceiling(1.1 * nsize) + X$n + Y$n # now extract pairs z <- .C(SG_Fcrosspairs, nn1=as.integer(X$n), x1=as.double(Xsort$x), y1=as.double(Xsort$y), nn2=as.integer(Y$n), x2=as.double(Ysort$x), y2=as.double(Ysort$y), r=as.double(rmax), noutmax=as.integer(nsize), nout=as.integer(integer(1L)), iout=as.integer(integer(nsize)), jout=as.integer(integer(nsize)), xiout=as.double(numeric(nsize)), yiout=as.double(numeric(nsize)), xjout=as.double(numeric(nsize)), yjout=as.double(numeric(nsize)), dxout=as.double(numeric(nsize)), dyout=as.double(numeric(nsize)), dout=as.double(numeric(nsize)), status=as.integer(integer(1L)), PACKAGE="spatstat.geom") if(z$status != 0) stop(paste("Internal error: C routine complains that insufficient space was allocated:", nsize)) # trim vectors to the length indicated npairs <- z$nout if(npairs <= 0) return(null.answer) actual <- seq_len(npairs) i <- z$iout[actual] # sic j <- z$jout[actual] xi <- z$xiout[actual] yi <- z$yiout[actual] xj <- z$xjout[actual] yj <- z$yjout[actual] dx <- z$dxout[actual] dy <- z$dyout[actual] d <- z$dout[actual] } # convert i,j indices to original sequences i <- ooX[i] j <- ooY[j] # done switch(what, all = { answer <- list(i=i, j=j, xi=xi, yi=yi, xj=xj, yj=yj, dx=dx, dy=dy, d=d) }, indices = { answer <- list(i=i, j=j) }, ijd = { answer <- list(i=i, j=j, d=d) }) if(!is.null(iX) && !is.null(iY)) answer <- remove.identical.pairs(answer, iX, iY) return(answer) } closethresh <- function(X, R, S, twice=TRUE, ...) { # list all R-close pairs # and indicate which of them are S-close (S < R) # so that results are consistent with closepairs(X,S) verifyclass(X, "ppp") stopifnot(is.numeric(R) && length(R) == 1L && R >= 0) stopifnot(is.numeric(S) && length(S) == 1L && S >= 0) stopifnot(S < R) ordered <- list(...)$ordered if(missing(twice) && !is.null(ordered)) { warning("Obsolete argument 'ordered' has been replaced by 'twice'") twice <- ordered } npts <- npoints(X) if(npts <= 1) return(list(i=integer(0), j=integer(0), t=logical(0))) # sort points by increasing x coordinate oo <- fave.order(X$x) Xsort <- X[oo] ## First make an OVERESTIMATE of the number of pairs npairs <- as.double(npts) * (as.double(npts) - 1) if(npairs <= 1024) { nsize <- 1024 } else { catchfraction <- pi * (R^2)/area(Frame(X)) nsize <- ceiling(4 * catchfraction * npairs) nsize <- min(nsize, npairs) nsize <- max(1024, nsize) if(nsize > .Machine$integer.max) { warning( "Estimated number of close pairs exceeds maximum possible integer", call.=FALSE) nsize <- .Machine$integer.max } } # Now extract pairs x <- Xsort$x y <- Xsort$y r <- R s <- S ng <- nsize storage.mode(x) <- "double" storage.mode(y) <- "double" storage.mode(r) <- "double" storage.mode(s) <- "double" storage.mode(ng) <- "integer" z <- .Call(SG_Vclosethresh, xx=x, yy=y, rr=r, ss=s, nguess=ng, PACKAGE="spatstat.geom") if(length(z) != 3) stop("Internal error: incorrect format returned from Vclosethresh") i <- z[[1L]] # NB no increment required j <- z[[2L]] th <- as.logical(z[[3L]]) # convert i,j indices to original sequence i <- oo[i] j <- oo[j] # fast C code only returns i < j if(twice) { iold <- i jold <- j i <- c(iold, jold) j <- c(jold, iold) th <- rep(th, 2) } # done return(list(i=i, j=j, th=th)) } crosspairquad <- function(Q, rmax, what=c("all", "indices")) { # find all close pairs X[i], U[j] stopifnot(inherits(Q, "quad")) what <- match.arg(what) X <- Q$data D <- Q$dummy clX <- closepairs(X=X, rmax=rmax, what=what) clXD <- crosspairs(X=X, Y=D, rmax=rmax, what=what) # convert all indices to serial numbers in union.quad(Q) # assumes data are listed first clXD$j <- npoints(X) + clXD$j result <- as.list(rbind(as.data.frame(clX), as.data.frame(clXD))) return(result) } tweak.closepairs <- function(cl, rmax, i, deltax, deltay, deltaz) { stopifnot(is.list(cl)) stopifnot(all(c("i", "j") %in% names(cl))) if(!any(c("xi", "dx") %in% names(cl))) stop("Insufficient data to update closepairs list") check.1.real(rmax) check.1.integer(i) check.1.real(deltax) check.1.real(deltay) if("dz" %in% names(cl)) check.1.real(deltaz) else { deltaz <- NULL } hit.i <- (cl$i == i) hit.j <- (cl$j == i) if(any(hit.i | hit.j)) { mm <- hit.i & !hit.j if(any(mm)) { cl$xi[mm] <- cl$xi[mm] + deltax cl$yi[mm] <- cl$yi[mm] + deltay cl$dx[mm] <- cl$dx[mm] - deltax cl$dy[mm] <- cl$dy[mm] - deltay if(is.null(deltaz)) { cl$d[mm] <- sqrt(cl$dx[mm]^2 + cl$dy[mm]^2) } else { cl$zi[mm] <- cl$zi[mm] + deltaz cl$dz[mm] <- cl$dz[mm] - deltaz cl$d[mm] <- sqrt(cl$dx[mm]^2 + cl$dy[mm]^2 + cl$dz[mm]^2) } } mm <- hit.j & !hit.i if(any(mm)) { cl$xj[mm] <- cl$xj[mm] + deltax cl$yj[mm] <- cl$yj[mm] + deltay cl$dx[mm] <- cl$dx[mm] + deltax cl$dy[mm] <- cl$dy[mm] + deltay if(is.null(deltaz)) { cl$d[mm] <- sqrt(cl$dx[mm]^2 + cl$dy[mm]^2) } else { cl$zj[mm] <- cl$zj[mm] + deltaz cl$dz[mm] <- cl$dz[mm] + deltaz cl$d[mm] <- sqrt(cl$dx[mm]^2 + cl$dy[mm]^2 + cl$dz[mm]^2) } } mm <- hit.i & hit.j if(any(mm)) { cl$xi[mm] <- cl$xi[mm] + deltax cl$xj[mm] <- cl$xj[mm] + deltax cl$yi[mm] <- cl$yi[mm] + deltay cl$yj[mm] <- cl$yj[mm] + deltay if(!is.null(deltaz)) { cl$zi[mm] <- cl$zi[mm] + deltaz cl$zj[mm] <- cl$zj[mm] + deltaz } } if(any(lost <- (cl$d > rmax))) cl <- as.list(as.data.frame(cl)[!lost, , drop=FALSE]) } return(cl) } remove.identical.pairs <- function(cl, imap, jmap) { ## 'cl' is the result of crosspairs ## 'imap', 'jmap' map the 'i' and 'j' indices to a common sequence distinct <- (imap[cl$i] != jmap[cl$j]) if(!all(distinct)) cl <- lapply(cl, "[", i=distinct) return(cl) } spatstat.geom/R/convexdist.R0000644000176200001440000002674214611065351015572 0ustar liggesusers#' convexdist.R #' #' Distance metric whose unit ball is a given, symmetric, convex polygon. #' #' $Revision: 1.20 $ $Date: 2022/05/21 09:52:11 $ convexmetric <- local({ #' .......... utilities ...................... sptvex <- function(K, origin=c(0,0), show=FALSE) { ## find the support vectors of convex polygon K if(!missing(origin)) K <- shift(K, origin=origin) v <- vertices(convexhull(K)) x <- v$x y <- v$y dx <- diff(c(x, x[1])) dy <- diff(c(y, y[1])) ll <- sqrt(dx^2+dy^2) co <- dy/ll si <- -dx/ll p <- co * x + si * y if(any(bad <- !(is.finite(co) & is.finite(si)))) { ## very short segment - direction cannot be determined - use midpoint xmid <- x + dx/2 ymid <- y + dy/2 ll[bad] <- sqrt(xmid[bad]^2 + ymid[bad]^2) co[bad] <- ymid[bad]/ll[bad] si[bad] <- -xmid[bad]/ll[bad] p[bad] <- co[bad] * x[bad] + si[bad] * y[bad] if(any(verybad <- !(is.finite(co) & is.finite(si)))) { ## very short segment, very close to origin - remove it retain <- !verybad co <- co[retain] si <- si[retain] p <- p[retain] } } if(show) { B <- boundingbox(Frame(K), bounding.box.xy(p*co, p*si)) plot(B, type="n", main="") plot(K, add=TRUE) points(0,0,pch=3) points(p * co, p * si) plot(infline(p=p, theta=atan2(si,co)), lty=3) } return(data.frame(co=co, si=si, p=p)) } ## find support vectors after enforcing convexity and exact symmetry sptvexsym <- function(K, standardise=TRUE) { K <- convexhull(K) sp <- sptvex(K, show=FALSE) spr <- sptvex(reflect(K), show=FALSE) sp <- rbind(sp, spr) sp <- sp[!duplicated(sp), , drop=FALSE] if(standardise) { sp$co <- sp$co/sp$p sp$si <- sp$si/sp$p } return(sp) } #' .......... main 'engine' functions ...................... convexpairdist <- function(X, sp) { nX <- npoints(X) if(nX <= 1) return(matrix(0, nX, nX)) a <- coords(X) dx <- outer(a$x, a$x, "-") dy <- outer(a$y, a$y, "-") ex <- sp$co ey <- sp$si for(i in seq_len(nrow(sp))) { ri <- dx * ex[i] + dy * ey[i] if(i == 1) r <- ri else r[] <- pmax(r, ri) } return(r) } convexnndist <- function(X, sp, k=1L) { d <- convexpairdist(X, sp) diag(d) <- Inf nn <- PDtoNN(d, "dist", k=k) return(nn) } convexnnwhich <- function(X, sp, k=1L) { d <- convexpairdist(X, sp) diag(d) <- Inf nw <- PDtoNN(d, "which", k=k) return(nw) } convexcrossdist <- function(X, Y, sp) { if(npoints(X) == 0 || npoints(Y) == 0) return(matrix(0, npoints(X), npoints(Y))) ex <- sp$co ey <- sp$si a <- coords(X) b <- coords(Y) dx <- outer(a$x, b$x, "-") dy <- outer(a$y, b$y, "-") for(i in seq_len(nrow(sp))) { ri <- dx * ex[i] + dy * ey[i] if(i == 1) r <- ri else r[] <- pmax(r, ri) } return(r) } convexnncross <- function(X, Y, sp, ve, iX=NULL, iY=NULL, what=c("dist", "which"), k=1L) { #' X is a point pattern #' Y is a point pattern or segment pattern what <- match.arg(what, several.ok=TRUE) nX <- npoints(X) nY <- nobjects(Y) if(nX == 0 || nY == 0) { d <- matrix(Inf, nX, nY) } else if(is.ppp(Y)) { d <- convexcrossdist(X, Y, sp) } else if(is.psp(Y)) { d <- convexPxS(X, Y, sp, ve) } else stop("Y should be a point pattern or line segment pattern") result <- XDtoNN(d, what=what, iX=iX, iY=iY, k=k) return(result) } convexPxS <- function(X, Y, sp, ve) { #' convex distance from each point of X to each segment in Y #' requires vertices as well as support vectors stopifnot(is.ppp(X)) stopifnot(is.psp(Y)) nX <- npoints(X) nY <- nsegments(Y) if(nX == 0 || nY == 0) return(matrix(, nX, nY)) #' vertices - distance from origin vl <- with(ve, sqrt(x^2+y^2)) nv <- length(vl) #' distances from points of X to endpoints of Y D1 <- convexcrossdist(X, endpoints.psp(Y, "first"), sp) D2 <- convexcrossdist(X, endpoints.psp(Y, "second"), sp) D <- matrix(pmin(D1, D2), nX, nY) dmax <- apply(D, 1, max) #' distances from points of X to locations on segments B <- boundingbox(Frame(X), Frame(Y)) B <- grow.rectangle(B, max(dmax) * max(vl)) coX <- coords(X) xx <- coX[, "x"] yy <- coX[, "y"] for(i in 1:nrow(coX)) { #' construct segments from X[i] along expansion line of each vertex Zi <- psp(rep(xx[i], nv), rep(yy[i], nv), xx[i] + dmax[i] * ve$x, yy[i] + dmax[i] * ve$y, window=B) #' intersect with target segments V <- crossing.psp(Zi, Y, details=TRUE) if(npoints(V) > 0) { marv <- marks(V) #' crossing point with which target segment? jj <- marv$jB #' crossing point of extension of which vertex? kk <- marv$iA #' Euclidean distance from X[i] to crossing point dE <- crossdist(X[i], V) #' metric distance dd <- dE/vl[kk] #' minimise over each target segment oo <- order(jj, dd) jj <- jj[oo] dd <- dd[oo] ok <- !duplicated(jj) jj <- jj[ok] dd <- dd[ok] #' minimise D[i, jj] <- pmin(D[i, jj], dd) } } return(D) } convexdistmapmask <- function(w, sp, npasses=5, verbose=FALSE) { stopifnot(is.mask(w)) check.1.integer(npasses) ## get support vectors sx <- sp$co sy <- sp$si ns <- length(sx) ## pad out mask nr <- w$dim[1L] nc <- w$dim[2L] xcol <- w$xcol yrow <- w$yrow #' input image will be padded out with a margin of width 2 on all sides mr <- mc <- 2L #' full dimensions of padded image Nnr <- nr + 2 * mr Nnc <- nc + 2 * mc N <- Nnr * Nnc #' output image (subset): rows & columns (R indexing) rmin <- mr + 1L rmax <- Nnr - mr cmin <- mc + 1L cmax <- Nnc - mc #' do padding x <- matrix(FALSE, nrow=Nnr, ncol=Nnc) x[rmin:rmax, cmin:cmax] <- w$m #' compute distmap res <- .C(SG_mdtPconv, as.double(xcol[1L]), as.double(yrow[1L]), as.double(xcol[nc]), as.double(yrow[nr]), nr = as.integer(nr), nc = as.integer(nc), mr = as.integer(mr), mc = as.integer(mc), inp = as.integer(t(x)), ns = as.integer(ns), sx = as.double(sx), sy = as.double(sy), npasses = as.integer(npasses), distances = as.double (double(N)), rows = as.integer(integer(N)), cols = as.integer(integer(N)), PACKAGE="spatstat.geom") dist <- matrix(res$distances, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] result <- as.im(dist, w) edge <- TRUE if(edge) { #' calculate distance transform to boundary y <- x y[] <- TRUE y[rmin:rmax, cmin:cmax] <- FALSE y[rmin, ] <- TRUE y[rmax, ] <- TRUE y[, cmin] <- TRUE y[, cmax] <- TRUE #' compute distmap bres <- .C(SG_mdtPconv, as.double(xcol[1L]), as.double(yrow[1L]), as.double(xcol[nc]), as.double(yrow[nr]), nr = as.integer(nr), nc = as.integer(nc), mr = as.integer(mr), mc = as.integer(mc), inp = as.integer(t(y)), ns = as.integer(ns), sx = as.double(sx), sy = as.double(sy), npasses = as.integer(npasses), distances = as.double (double(N)), rows = as.integer(integer(N)), cols = as.integer(integer(N)), PACKAGE="spatstat.geom") bdist <- matrix(bres$distances, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] bdist <- as.im(bdist, w) attr(result, "bdist") <- bdist } return(result) } #' >>>>>>>>>>>>>> Function to create a metric <<<<<<<<<<<<<<<<<<<<<< convexmetric <- function(K) { stopifnot(is.owin(K)) stopifnot(is.convex(K)) if(!inside.owin(0, 0, K)) stop("The origin (0,0) must be inside the set K") if(bdist.points(ppp(0, 0, window=K)) < sqrt(.Machine$double.eps)) stop("The origin (0,0) must lie in the interior of K") ## vertices of K vertK <- vertices(K) ## support vectors of K spK <- sptvexsym(K, standardise=TRUE) if(!all(is.finite(unlist(spK)))) stop("Support vectors are singular (infinite or undefined)", call.=FALSE) ## build object in this environment so that K, spK, vertK are accessible result <- list( pairdist.ppp=function(X, ..., squared=FALSE) { warn.unsupported.args(list(periodic=FALSE, method="C"), ...) y <- convexpairdist(X, spK) return(if(squared) y^2 else y) }, nndist.ppp=function(X, ..., k=1L) { warn.unsupported.args(list(by=NULL, method="C"), ...) convexnndist(X, spK, k=k) }, nnwhich.ppp=function(X, ..., k=1L) { warn.unsupported.args(list(by=NULL, method="C"), ...) convexnnwhich(X, spK, k=k) }, crossdist.ppp=function(X, Y, ..., squared=FALSE) { warn.unsupported.args(list(periodic=FALSE, method="C"), ...) y <- convexcrossdist(X,Y,spK) return(if(squared) y^2 else y) }, nncross.ppp=function(X,Y,iX=NULL, iY=NULL, what=c("dist","which"), ..., k=1L) { warn.unsupported.args(list(sortby=c("range", "var", "x", "y"), is.sorted.X=FALSE, is.sorted.Y=FALSE), ...) convexnncross(X,Y,spK,vertK, iX, iY, what, k) }, distmap.ppp=function(X, ...) { warn.unsupported.args(list(clip=FALSE), ...) w <- pixellate(X, ..., preserve=TRUE) w <- solutionset(w > 0) convexdistmapmask(w, spK) }, distmap.owin=function(X, ...) { warn.unsupported.args(list(discretise=FALSE, invert=FALSE), ...) w <- do.call.matched(as.mask, list(w=quote(X), ...)) convexdistmapmask(w, spK) }, distmap.psp=function(X, ...) { warn.unsupported.args(list(extras=TRUE, clip=FALSE), ...) w <- do.call.matched(psp2mask, list(x=quote(X), ...), extrargs=names(formals(as.mask))[-1]) convexdistmapmask(w, spK) }, disc=function(radius=1, centre=c(0,0), ..., mask=FALSE) { warn.unsupported.args(list(npoly=128, delta=NULL), ...) check.1.real(radius) stopifnot(radius > 0) centre <- as2vector(centre) B <- shift(scalardilate(K, radius), vec=centre) if(mask) B <- as.mask(B, ...) return(B) }, print=function(...) { splat("Distance metric defined by the convex set:") print(K, prefix="\t") invisible(NULL) } ) class(result) <- "metric" return(result) } class(convexmetric) <- "metricfun" attr(convexmetric, "explain") <- "Creates a distance metric based on a convex set K" convexmetric }) spatstat.geom/R/subset.R0000644000176200001440000000645114611065352014705 0ustar liggesusers## ## subset.R ## ## Methods for 'subset' ## ## $Revision: 1.7 $ $Date: 2020/06/16 03:19:55 $ subset.ppp <- function(x, subset, select, drop=FALSE, ...) { stopifnot(is.ppp(x)) w <- as.owin(x) y <- as.data.frame(x) r <- if (missing(subset)) { rep_len(TRUE, nrow(y)) } else { e <- substitute(subset) r <- eval(e, y, parent.frame()) if(!is.logical(r)) r <- ppsubset(x, r, "subset", fatal=TRUE) r & !is.na(r) } vars <- if (missing(select)) { TRUE } else { ## create an environment in which column names are mapped to their positions nl <- as.list(seq_along(y)) names(nl) <- names(y) if(length(nl) > 3) { ## multiple columns of marks: add the name 'marks' nl <- append(nl, list(marks=3:length(nl))) } eval(substitute(select), nl, parent.frame()) } ## ensure columns include coordinates nama <- names(y) names(nama) <- nama vars <- union(c("x", "y"), nama[vars]) ## take subset z <- y[r, vars, drop = FALSE] ## reinstate as point pattern out <- as.ppp(z, W=w, check=FALSE) if(drop) out <- out[drop=TRUE] return(out) } subset.pp3 <- subset.ppx <- function(x, subset, select, drop=FALSE, ...) { y <- as.data.frame(x) r <- if (missing(subset)) rep_len(TRUE, nrow(y)) else { e <- substitute(subset) r <- eval(e, y, parent.frame()) if(!is.logical(r)) r <- ppsubset(x, r, "subset", fatal=TRUE) r & !is.na(r) } vars <- if (missing(select)) TRUE else { ## create an environment in which column names are mapped to their positions nl <- as.list(seq_along(y)) names(nl) <- names(y) if(!("marks" %in% names(y)) && any(ismark <- (x$ctype == "mark"))) { ## add the symbol 'marks' nl <- append(nl, list(marks=which(ismark))) } eval(substitute(select), nl, parent.frame()) } ## ensure columns include coordinates nama <- names(y) names(nama) <- nama vars <- union(names(coords(x)), nama[vars]) ## take subset z <- y[r, vars, drop = FALSE] ## reinstate as point pattern ctype <- as.character(x$ctype)[match(vars, nama)] out <- ppx(z, domain=x$domain, coord.type=ctype) ## drop unused factor levels if(drop) out <- out[drop=TRUE] ## reinstate class class(out) <- class(x) return(out) } subset.psp <- function(x, subset, select, drop=FALSE, ...) { stopifnot(is.psp(x)) w <- Window(x) y <- as.data.frame(x) r <- if (missing(subset)) { rep_len(TRUE, nrow(y)) } else { e <- substitute(subset) r <- eval(e, y, parent.frame()) if(!is.logical(r)) stop("Argument 'subset' should be a logical vector", call.=FALSE) r & !is.na(r) } vars <- if (missing(select)) { TRUE } else { ## create an environment in which column names are mapped to their positions nl <- as.list(seq_along(y)) names(nl) <- names(y) if(length(nl) > 3) { ## multiple columns of marks: add the name 'marks' nl <- append(nl, list(marks=3:length(nl))) } eval(substitute(select), nl, parent.frame()) } ## ensure columns include coordinates nama <- names(y) names(nama) <- nama vars <- union(c("x0", "y0", "x1", "y1"), nama[vars]) ## take subset z <- y[r, vars, drop = FALSE] ## reinstate as line segment pattern out <- as.psp(z, window=w, check=FALSE) if(drop) out <- out[drop=TRUE] return(out) } spatstat.geom/R/rasterfilter.R0000644000176200001440000000217114611065352016101 0ustar liggesusers#' #' rasterfilter.R #' #' raster filters implemented directly #' #' $Revision: 1.7 $ $Date: 2022/05/21 09:52:11 $ #' rasterfilter <- function(X, f) { X <- as.im(X) dimX <- dim(X) f <- as.matrix(f) if(!all(dim(f) == 3)) stop("f should be a 3 x 3 matrix or image") #' handle NA v <- as.double(X$v) if(hasna <- anyNA(v)) { isna <- is.na(v) v[isna] <- 0 } #' compute z <- .C(SG_raster3filter, nx = as.integer(dimX[2]), ny = as.integer(dimX[1]), a = as.double(v), w = as.double(f), b = as.double(numeric(prod(dimX))), PACKAGE="spatstat.geom") z <- z$b #' handle NA if(hasna) z[isna] <- NA # replace X[] <- z return(X) } #' antialiasing smudge <- function(X) { stopifnot(is.im(X)) xstep <- X$xstep ystep <- X$ystep #' choose a very small bandwidth sigma <- min(xstep, ystep)/2 #' match variance: 2 p step^2 = sigma^2 px <- sigma^2/(2 * xstep^2) py <- sigma^2/(2 * ystep^2) f <- outer(c(py, 1-2*py, py), c(px, 1-2*px, px), "*") #' compute Z <- rasterfilter(X, f) attr(Z, "sigma") <- sigma return(Z) } spatstat.geom/R/distbdry.R0000644000176200001440000001757614611065351015235 0ustar liggesusers# # distbdry.S Distance to boundary # # $Revision: 4.49 $ $Date: 2022/03/31 01:13:38 $ # # -------- functions ---------------------------------------- # # bdist.points() # compute vector of distances # from each point of point pattern # to boundary of window # # bdist.pixels() # compute matrix of distances from each pixel # to boundary of window # # erodemask() erode the window mask by a distance r # [yields a new window] # # # "bdist.points"<- function(X) { verifyclass(X, "ppp") if(X$n == 0) return(numeric(0)) x <- X$x y <- X$y window <- X$window switch(window$type, rectangle = { xmin <- min(window$xrange) xmax <- max(window$xrange) ymin <- min(window$yrange) ymax <- max(window$yrange) result <- pmin.int(x - xmin, xmax - x, y - ymin, ymax - y) }, polygonal = { xy <- cbind(x,y) ll <- edges(window)$ends result <- distppllmin(xy, ll)$min.d }, mask = { b <- bdist.pixels(window, style="matrix") loc <- nearest.raster.point(x,y,window) result <- b[cbind(loc$row, loc$col)] }, stop("Unrecognised window type", window$type) ) return(result) } "bdist.pixels" <- function(w, ..., style=c("image", "matrix", "coords"), method=c("C", "interpreted")) { verifyclass(w, "owin") style <- match.arg(style) masque <- as.mask(w, ...) switch(w$type, mask = { neg <- complement.owin(masque) m <- exactPdt(neg) b <- pmin.int(m$d,m$b) }, rectangle = { rxy <- rasterxy.mask(masque) x <- rxy$x y <- rxy$y xmin <- w$xrange[1L] xmax <- w$xrange[2L] ymin <- w$yrange[1L] ymax <- w$yrange[2L] b <- pmin.int(x - xmin, xmax - x, y - ymin, ymax - y) }, polygonal = { # set up pixel raster method <- match.arg(method) rxy <- rasterxy.mask(masque) x <- rxy$x y <- rxy$y b <- numeric(length(x)) # test each pixel in/out, analytically inside <- inside.owin(x, y, w) # compute distances for these pixels xy <- cbind(x[inside], y[inside]) switch(method, C = { #' C code ll <- as.data.frame(edges(w)) dxy <- distppllmin(xy, ll)$min.d }, interpreted = { #' ancient R code dxy <- rep.int(Inf, sum(inside)) bdry <- w$bdry for(i in seq_along(bdry)) { polly <- bdry[[i]] nsegs <- length(polly$x) for(j in 1:nsegs) { j1 <- if(j < nsegs) j + 1L else 1L seg <- c(polly$x[j], polly$y[j], polly$x[j1], polly$y[j1]) dxy <- pmin.int(dxy, distppl(xy, seg)) } } }) b[inside] <- dxy }, stop("unrecognised window type", w$type) ) # reshape it b <- matrix(b, nrow=masque$dim[1L], ncol=masque$dim[2L]) switch(style, coords={ # format which can be plotted by image(), persp() etc return(list(x=masque$xcol, y=masque$yrow, z=t(b))) }, matrix={ # return matrix (for internal use by package) return(b) }, image={ bim <- im(b, xcol=masque$xcol, yrow=masque$yrow, unitname=unitname(masque)) return(bim) }, stop(paste("Unrecognised option for style:", style))) } framedist.pixels <- function(w, ..., style=c("image", "matrix", "coords")) { ## Distance to Frame boundary style <- match.arg(style) masque <- as.mask(w, ...) rxy <- rasterxy.mask(masque) x <- rxy$x y <- rxy$y xmin <- w$xrange[1L] xmax <- w$xrange[2L] ymin <- w$yrange[1L] ymax <- w$yrange[2L] b <- pmin.int(x - xmin, xmax - x, y - ymin, ymax - y) b <- matrix(b, nrow=masque$dim[1L], ncol=masque$dim[2L]) result <- switch(style, matrix = b, coords = list(x=masque$xcol, y=masque$yrow, z=t(b)), image = im(b, xcol=masque$xcol, yrow=masque$yrow, unitname=unitname(masque))) return(result) } erodemask <- function(w, r, strict=FALSE) { # erode a binary image mask without changing any other entries verifyclass(w, "owin") if(w$type != "mask") stop(paste("window w is not of type", sQuote("mask"))) if(!is.numeric(r) || length(r) != 1L) stop("r must be a single number") if(r < 0) stop("r must be nonnegative") bb <- bdist.pixels(w, style="matrix") if(r > max(bb)) warning("eroded mask is empty") if(identical(strict, TRUE)) w$m <- (bb > r) else w$m <- (bb >= r) return(w) } "Frame<-.owin" <- function(X, value) { stopifnot(is.rectangle(value)) W <- Frame(X) if(!is.subset.owin(W, value)) W <- intersect.owin(W, value) rebound.owin(X, value) } rebound.owin <- local({ rebound.owin <- function(x, rect) { w <- x verifyclass(rect, "owin") if(is.empty(w)) return(emptywindow(rect)) verifyclass(w, "owin") if(!is.subset.owin(as.rectangle(w), rect)) { bb <- boundingbox(w) if(!is.subset.owin(bb, rect)) stop(paste("The new rectangle", sQuote("rect"), "does not contain the window", sQuote("win"))) } xr <- rect$xrange yr <- rect$yrange ## determine unitname uu <- list(unitname(x), unitname(rect)) uu <- unique(uu[sapply(uu, is.vanilla)]) if(length(uu) > 1) { warning("Arguments of rebound.owin have incompatible unitnames", call.=FALSE) uu <- list() } un <- if(length(uu)) uu[[1]] else NULL ## switch(w$type, rectangle={ return(owin(xr, yr, poly=list(x=w$xrange[c(1L,2L,2L,1L)], y=w$yrange[c(1L,1L,2L,2L)]), unitname = un, check=FALSE)) }, polygonal={ return(owin(xr, yr, poly=w$bdry, unitname=un, check=FALSE)) }, mask={ xcol <- newseq(w$xcol, xr) yrow <- newseq(w$yrow, yr) newmask <- as.mask(xy=list(x=xcol, y=yrow)) xx <- rasterx.mask(newmask) yy <- rastery.mask(newmask) newmask$m <- inside.owin(xx, yy, w) unitname(newmask) <- un return(newmask) } ) } newseq <- function(oldseq, newrange) { oldrange <- range(oldseq) dstep <- mean(diff(oldseq)) nleft <- max(0, floor((oldrange[1L] - newrange[1L])/dstep)) nright <- max(0, floor((newrange[2L] - oldrange[2L])/dstep)) newstart <- max(oldrange[1L] - nleft * dstep, newrange[1L]) newend <- min(oldrange[2L] + nright * dstep, newrange[2L]) seq(from=newstart, by=dstep, to=newend) } rebound.owin }) spatstat.geom/R/morphology.R0000644000176200001440000002426014611065352015575 0ustar liggesusers# # morphology.R # # dilation, erosion, opening, closing # # generic functions # and methods for owin, psp, ppp # # $Revision: 1.33 $ $Date: 2020/03/16 10:28:51 $ # # ............ generic ............................ erosion <- function(w, r, ...) { UseMethod("erosion") } dilation <- function(w, r, ...) { UseMethod("dilation") } closing <- function(w, r, ...) { UseMethod("closing") } opening <- function(w, r, ...) { UseMethod("opening") } # ............ methods for class 'owin' ............................ # DELETED # erode.owin <- function(...) { # .Deprecated("erosion.owin", package="spatstat") # erosion.owin(...) # } erosion.owin <- function(w, r, shrink.frame=TRUE, ..., strict=FALSE, polygonal=NULL) { verifyclass(w, "owin") validradius(r, "erosion") if(r == 0 && !strict) return(w) xr <- w$xrange yr <- w$yrange if(2 * r >= max(diff(xr), diff(yr))) stop("erosion distance r too large for frame of window") # compute the dimensions of the eroded frame exr <- xr + c(r, -r) eyr <- yr + c(r, -r) ebox <- list(x=exr[c(1,2,2,1)], y=eyr[c(1,1,2,2)]) ismask <- is.mask(w) if(is.empty(w)) return(emptywindow(ebox)) # determine type of computation if(is.null(polygonal)) polygonal <- !ismask else { stopifnot(is.logical(polygonal)) if(polygonal && ismask) { # try to convert w <- as.polygonal(w) if(is.mask(w)) polygonal <- FALSE } } if(is.rectangle(w) && polygonal) { # result is a smaller rectangle if(shrink.frame) { return(owinInternalRect(exr, eyr)) # type 'rectangle' } else { return(owin(xr, yr, poly=ebox, check=FALSE)) # type 'polygonal' } } if(polygonal) { # compute polygonal region using polyclip package pnew <- polyclip::polyoffset(w$bdry, -r, jointype="round") # ensure correct polarity totarea <- sum(unlist(lapply(pnew, Area.xypolygon))) if(totarea < 0) pnew <- lapply(pnew, reverse.xypolygon) if(shrink.frame) { return(owin(poly=pnew, check=FALSE)) } else { return(owin( xr, yr, poly=pnew, check=FALSE)) } } # otherwise erode the window in pixel image form if(w$type == "mask") wnew <- erodemask(w, r, strict=strict) else { D <- distmap(w, invert=TRUE, ...) wnew <- levelset(D, r, if(strict) ">" else ">=") } if(shrink.frame) { # trim off some rows & columns of pixel raster keepcol <- (wnew$xcol >= exr[1] & wnew$xcol <= exr[2]) keeprow <- (wnew$yrow >= eyr[1] & wnew$yrow <= eyr[2]) wnew$xcol <- wnew$xcol[keepcol] wnew$yrow <- wnew$yrow[keeprow] wnew$dim <- c(sum(keeprow), sum(keepcol)) wnew$m <- wnew$m[keeprow, keepcol] wnew$xrange <- exr wnew$yrange <- eyr } return(wnew) } # DELETED # dilate.owin <- function(...) { # .Deprecated("dilation.owin", package="spatstat") # dilation.owin(...) # } dilation.owin <- function(w, r, ..., polygonal=NULL, tight=TRUE) { verifyclass(w, "owin") validradius(r, "dilation") if(r == 0) return(w) ismask <- is.mask(w) if(is.empty(w)) return(w) # determine type of computation if(is.null(polygonal)) { polygonal <- !ismask } else stopifnot(is.logical(polygonal)) if(polygonal) { # convert to polygonal w <- as.polygonal(w) if(!is.polygonal(w)) polygonal <- FALSE } # bounding frame bb <- if(tight) boundingbox(w) else as.rectangle(w) newbox <- grow.rectangle(bb, r) # compute dilation if(!polygonal) { # compute pixel approximation epsilon <- sqrt(w$xstep^2 + w$ystep^2) r <- max(r, epsilon) w <- rebound.owin(w, newbox) distant <- distmap(w, ...) dil <- levelset(distant, r, "<=") return(dil) } else { # compute polygonal region using polyclip package pnew <- polyclip::polyoffset(w$bdry, r, jointype="round") # ensure correct polarity totarea <- sum(unlist(lapply(pnew, Area.xypolygon))) if(totarea < 0) pnew <- lapply(pnew, reverse.xypolygon) # determine bounding frame, convert to owin if(tight) { out <- owin(poly=pnew, check=FALSE) } else { out <- owin(newbox$xrange, newbox$yrange, poly=pnew, check=FALSE) } return(out) } } closing.owin <- function(w, r, ..., polygonal=NULL) { if(missing(r)) stop("r is required") validradius(r, "closing") wplus <- dilation.owin(w, r, ..., polygonal=polygonal, tight=FALSE) if(is.empty(wplus)) return(wplus) wclose <- erosion.owin(wplus, r, strict=TRUE) b <- as.rectangle(w) wclose <- rebound.owin(wclose[b], b) return(wclose) } opening.owin <- function(w, r, ..., polygonal=NULL) { if(missing(r)) stop("r is required") validradius(r, "opening") wminus <- erosion.owin(w, r, ..., polygonal=polygonal, shrink.frame=FALSE) if(is.empty(wminus)) return(wminus) wopen <- dilation.owin(wminus, r, tight=FALSE) b <- as.rectangle(w) wopen <- rebound.owin(wopen[b], b) return(wopen) } border <- function(w, r, outside=FALSE, ...) { w <- as.owin(w) if(!outside) { e <- erosion(w, r, ...) b <- setminus.owin(w, e) } else { d <- dilation(w, r, ...) b <- setminus.owin(d, w) } return(b) } # ............ methods for class 'psp' ............................ dilation.psp <- function(w, r, ..., polygonal=TRUE, tight=TRUE) { verifyclass(w, "psp") x <- w validradius(r, "dilation") if(r == 0) return(w) if(is.empty(x)) return(emptywindow(as.owin(w))) # bounding frame bb <- if(tight) boundingbox(x) else as.rectangle(x) newbox <- grow.rectangle(bb, r) # compute dilation if(!polygonal) { x <- rebound.psp(x, newbox) distant <- distmap(x, ...) dil <- levelset(distant, r, "<=") return(dil) } else if(spatstat.options("old.morpho.psp")) { # old code for polygonal case ends <- x$ends angles <- angles.psp(x, directed=TRUE) # lengths <- lengths_psp(x) out <- NULL # dilate individual segments halfcircle <- seq(from=0, to=pi, length.out=128)[-c(1,128)] for(i in seq_len(x$n)) { seg <- ends[i,] co <- cos(angles[i]) si <- sin(angles[i]) # draw sausage around i-th segment xx <- c(seg$x0, seg$x1) + r * si yy <- c(seg$y0, seg$y1) - r * co rightcircle <- angles[i] - pi/2 + halfcircle xx <- c(xx, seg$x1 + r * cos(rightcircle)) yy <- c(yy, seg$y1 + r * sin(rightcircle)) xx <- c(xx, c(seg$x1, seg$x0) - r * si) yy <- c(yy, c(seg$y1, seg$y0) + r * co) leftcircle <- angles[i] + pi/2 + halfcircle xx <- c(xx, seg$x0 + r * cos(leftcircle)) yy <- c(yy, seg$y0 + r * sin(leftcircle)) sausage <- owin(newbox$xrange, newbox$yrange, poly=list(x=xx, y=yy), check=FALSE) # add to set out <- union.owin(out, sausage, ...) } return(out) } else { # new code using 'polyclip' package # convert to list of list(x,y) ends <- as.matrix(x$ends) n <- nrow(ends) plines <- vector(mode="list", length=n) for(i in 1:n) plines[[i]] <- list(x=ends[i, c("x0","x1")], y=ends[i, c("y0","y1")]) # call pnew <- polyclip::polylineoffset(plines, r, jointype="round", endtype="openround") # ensure correct polarity totarea <- sum(unlist(lapply(pnew, Area.xypolygon))) if(totarea < 0) pnew <- lapply(pnew, reverse.xypolygon) # convert to owin object out <- if(tight) owin(poly=pnew, check=FALSE) else owin(newbox$xrange, newbox$yrange, poly=pnew, check=FALSE) return(out) } } closing.psp <- function(w, r, ..., polygonal=TRUE) { if(missing(r)) stop("r is required") validradius(r, "closing") wplus <- dilation.psp(w, r, ..., polygonal=polygonal, tight=FALSE) if(is.empty(wplus)) return(emptywindow(as.owin(w))) wclose <- erosion.owin(wplus, r, strict=TRUE) wclose <- rebound.owin(wclose, as.rectangle(w)) return(wclose) } erosion.psp <- function(w, r, ...) { idorempty(w, r, "erosion") } opening.psp <- function(w, r, ...) { idorempty(w, r,"opening") } # ............ methods for class 'ppp' ............................ dilation.ppp <- function(w, r, ..., polygonal=TRUE, tight=TRUE) { verifyclass(w, "ppp") validradius(r, "dilation") x <- w if(r == 0) return(x) if(is.empty(w)) return(emptywindow(as.owin(w))) # bounding frame bb <- if(tight) boundingbox(x) else as.rectangle(x) releps <- 1e-6 newbox <- grow.rectangle(bb, r * (1+releps)) # compute dilation if(!polygonal) { # compute pixel approximation Window(x) <- newbox distant <- distmap(x, ...) dil <- levelset(distant, r, "<=") return(dil) } else { # compute polygonal approximation # generate discs coo <- coords(x) nn <- npoints(x) balls <- vector(mode="list", length=nn) ball0 <- disc(r, c(0,0), ...) for(i in seq_len(nn)) balls[[i]] <- shift(ball0, vec=coo[i,]) class(balls) <- c("solist", class(balls)) out <- union.owin(balls) return(out) } } closing.ppp <- function(w, r, ..., polygonal=TRUE) { if(missing(r)) stop("r is required") validradius(r, "closing") if(is.empty(w) || w$n <= 3) return(emptywindow(as.owin(w))) # remove `isolated' points ok <- (nndist(w) <= 2 * r) if(sum(ok) <= 3) return(emptywindow(as.owin(w))) w <- w[ok] # dilate wplus <- dilation.ppp(w, r, ..., polygonal=polygonal, tight=FALSE) wclose <- erosion.owin(wplus, r, strict=TRUE) wclose <- rebound.owin(wclose, as.rectangle(w)) return(wclose) } erosion.ppp <- function(w, r, ...) { idorempty(w, r, "erosion") } opening.ppp <- function(w, r, ...) { idorempty(w, r,"opening") } # ............ utilities ............................ validradius <- local({ validradius <- function(r, caller="morphological operator") { # rname <- short.deparse(substitute(r)) if(!is.numeric(r) || length(r) != 1) groan("radius r must be a single number", caller) if(r < 0) groan("radius r must be nonnegative", caller) return(TRUE) } groan <- function(whinge, caller) { stop(paste("for", paste(caller, ",", sep=""), whinge), call.=FALSE) } validradius }) idorempty <- function(w, r, caller="morphological operator") { validradius(r, caller) if(r == 0) return(w) else return(emptywindow(w)) } spatstat.geom/R/nnfun.R0000644000176200001440000000750214611065352014522 0ustar liggesusers# # nnfun.R # # nearest neighbour function (returns a function of x,y) # # $Revision: 1.11 $ $Date: 2023/05/02 04:48:07 $ # nnfun <- function(X, ...) { UseMethod("nnfun") } nnfun.ppp <- function(X, ..., k=1, value=c("index", "mark")) { # this line forces X to be bound stopifnot(is.ppp(X)) if(length(k) != 1) stop("k should be a single integer") value <- match.arg(value) switch(value, index = { gi <- function(x,y=NULL) { Y <- xy.coords(x, y)[c("x", "y")] nncross(Y, X, what="which", k=k) } attr(gi, "Xclass") <- "ppp" g <- funxy(gi, as.rectangle(as.owin(X))) }, mark = { stopifnot(is.marked(X)) marx <- as.data.frame(marks(X))[,1] gm <- function(x,y=NULL) { Y <- xy.coords(x, y)[c("x", "y")] marx[nncross(Y, X, what="which", k=k)] } attr(gm, "Xclass") <- "ppp" g <- funxy(gm, as.rectangle(as.owin(X))) }) class(g) <- c("nnfun", class(g)) return(g) } nnfun.psp <- function(X, ..., value=c("index", "mark")) { # this line forces X to be bound stopifnot(is.psp(X)) value <- match.arg(value) switch(value, index = { gi <- function(x,y=NULL) { Y <- xy.coords(x, y)[c("x", "y")] nncross(Y, X, what="which") } attr(gi, "Xclass") <- "psp" g <- funxy(gi, as.rectangle(as.owin(X))) }, mark = { stopifnot(is.marked(X)) marx <- as.data.frame(marks(X))[,1] gm <- function(x,y=NULL) { Y <- xy.coords(x, y)[c("x", "y")] marx[nncross(Y, X, what="which")] } attr(gm, "Xclass") <- "psp" g <- funxy(gm, as.rectangle(as.owin(X))) }) class(g) <- c("nnfun", class(g)) return(g) } as.owin.nnfun <- function(W, ..., fatal=TRUE) { X <- get("X", envir=environment(W)) as.owin(X, ..., fatal=fatal) } domain.nnfun <- Window.nnfun <- function(X, ...) { as.owin(X) } as.im.nnfun <- function(X, W=NULL, ..., eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, approx=TRUE) { rule.eps <- match.arg(rule.eps) if(approx && is.null(W)) { env <- environment(X) Xdata <- get("X", envir=env) if(is.ppp(Xdata)) { #' fast approximation is supported only for point patterns k <- mget("k", envir=env, inherits=FALSE, ifnotfound=list(1))[[1L]] value <- mget("value", envir=env, ifnotfound=list(NULL))[[1L]] Z <- nnmap(Xdata, k=k, what="which", eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) if(identical(value, "mark")) { marx <- get("marx", envir=env) Z <- eval.im(marx[Z]) } if(!is.null(na.replace)) Z$v[is.null(Z$v)] <- na.replace return(Z) } } if(is.null(W)) W <- Window(X) result <- as.im.function(X, W=W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps, na.replace=na.replace, ...) return(result) } print.nnfun <- function(x, ...) { env <- environment(x) X <- get("X", envir=env) k <- mget("k", envir=env, inherits=FALSE, ifnotfound=list(1))[[1L]] v <- mget("value", envir=env, ifnotfound=list(NULL))[[1L]] xtype <- attr(x, "Xclass") typestring <- switch(xtype, ppp="point pattern", psp="line segment pattern", paste("object of class", sQuote(xtype))) Kth <- if(k == 1) "Nearest" else paste0(ordinal(k), "-Nearest") cat(paste(Kth, "Neighbour", if(is.null(v)) "Index" else "Mark", "function for ", typestring, "\n")) print(X) return(invisible(NULL)) } spatstat.geom/R/fft.R0000644000176200001440000000063114611065351014150 0ustar liggesusers#' #' fft.R #' #' choose code for computing Discrete Fourier Transform #' #' $Revision: 1.1 $ $Date: 2020/11/24 01:10:13 $ fft2D <- function(z, inverse=FALSE, west=fftwAvailable()) { if(west) return(fftwtools::fftw2d(data=z, inverse=inverse)) return(stats::fft(z=z, inverse=inverse)) } fftwAvailable <- function() { ok <- requireNamespace("fftwtools", quietly=TRUE) return(ok) } spatstat.geom/R/distances.psp.R0000644000176200001440000001124014611065351016145 0ustar liggesusers# # distances.psp.R # # Hausdorff distance and Euclidean separation for psp objects # # $Revision: 1.12 $ $Date: 2022/01/04 05:30:06 $ # # pairdist.psp <- function(X, ..., method="C", type="Hausdorff") { verifyclass(X, "psp") if(X$n == 0) return(matrix(, 0, 0)) type <- pickoption("type", type, c(Hausdorff="Hausdorff", hausdorff="Hausdorff", separation="separation")) D12 <- AsymmDistance.psp(X, X, metric=type, method=method) switch(type, Hausdorff={ # maximum is Hausdorff metric D <- array(pmax.int(D12, t(D12)), dim=dim(D12)) }, separation={ # Take minimum of endpoint-to-segment distances D <- array(pmin.int(D12, t(D12)), dim=dim(D12)) # Identify any pairs of segments which cross cross <- test.selfcrossing.psp(X) # Assign separation = 0 to such pairs D[cross] <- 0 }) return(D) } crossdist.psp <- function(X, Y, ..., method="C", type="Hausdorff") { verifyclass(X, "psp") Y <- as.psp(Y) if(X$n * Y$n == 0) return(matrix(, X$n, Y$n)) type <- pickoption("type", type, c(Hausdorff="Hausdorff", hausdorff="Hausdorff", separation="separation")) DXY <- AsymmDistance.psp(X, Y, metric=type, method=method) DYX <- AsymmDistance.psp(Y, X, metric=type, method=method) switch(type, Hausdorff={ # maximum is Hausdorff metric D <- array(pmax.int(DXY, t(DYX)), dim=dim(DXY)) }, separation={ # Take minimum of endpoint-to-segment distances D <- array(pmin.int(DXY, t(DYX)), dim=dim(DXY)) # Identify pairs of segments which cross cross <- test.crossing.psp(X, Y) # Assign separation = 0 to such pairs D[cross] <- 0 }) return(D) } nndist.psp <- function(X, ..., k=1, method="C") { verifyclass(X, "psp") if(!(is.vector(k) && all(k %% 1 == 0) && all(k >= 1))) stop("k should be a positive integer or integers") n <- nobjects(X) kmax <- max(k) lenk <- length(k) result <- if(lenk == 1) numeric(n) else matrix(, nrow=n, ncol=lenk) if(n == 0) return(result) if(kmax >= n) { # not enough objects # fill with Infinite values result[] <- Inf if(any(ok <- (kmax < n))) { # compute the lower-order nnd's result[, ok] <- nndist.psp(X, ..., k=k[ok], method=method) } return(result) } # normal case: D <- pairdist.psp(X, ..., method=method) diag(D) <- Inf if(kmax == 1L) NND <- apply(D, 1L, min) else NND <- t(apply(D, 1L, orderstats, k=k))[, , drop=TRUE] return(NND) } # ..... AsymmDistance.psp ..... # # If metric="Hausdorff": # this function computes, for each pair of segments A = X[i] and B = Y[j], # the value max_{a in A} d(a,B) = max_{a in A} min_{b in B} ||a-b|| # which appears in the definition of the Hausdorff metric. # Since the distance function d(a,B) of a segment B is a convex function, # the maximum is achieved at an endpoint of A. So the algorithm # actually computes h(A,B) = max (d(e_1,B), d(e_2,B)) where e_1, e_2 # are the endpoints of A. And H(A,B) = max(h(A,B),h(B,A)). # # If metric="separation": # the function computes, for each pair of segments A = X[i] and B = Y[j], # the MINIMUM distance from an endpoint of A to any point of B. # t(A,B) = min (d(e_1,B), d(e_2,B)) # where e_1, e_2 are the endpoints of A. # Define the separation distance # s(A,B) = min_{a in A} min_{b in B} ||a-b||. # The minimum (a*, b*) occurs either when a* is an endpoint of A, # or when b* is an endpoint of B, or when a* = b* (so A and B intersect). # (If A and B are parallel, the minimum is still achieved at an endpoint) # Thus s(A,B) = min(t(A,B), t(B,A)) unless A and B intersect. AsymmDistance.psp <- function(X, Y, metric="Hausdorff", method=c("C", "Fortran", "interpreted")) { method <- match.arg(method) # Extract endpoints of X EX <- endpoints.psp(X, "both") idX <- attr(EX, "id") # compute shortest dist from each endpoint of X to each segment of Y DPL <- distppll(cbind(EX$x,EX$y), Y$ends, mintype=0, method=method) # for each segment in X, maximise or minimise over the two endpoints Dist <- as.vector(DPL) Point <- as.vector(idX[row(DPL)]) Segment <- as.vector(col(DPL)) switch(metric, Hausdorff={ DXY <- tapply(Dist, list(factor(Point), factor(Segment)), max) }, separation={ DXY <- tapply(Dist, list(factor(Point), factor(Segment)), min) }) return(DXY) } spatstat.geom/R/persp.ppp.R0000644000176200001440000002006314723234257015330 0ustar liggesusers#' persp.ppp.R #' #' Perspective plot for marked point pattern #' #' Copyright (C) Adrian Baddeley 2024 #' GPL Public Licence >= 2.0 #' #' $Revision: 1.6 $ $Date: 2024/12/02 04:33:39 $ persp.ppp <- local({ persp.ppp <- function(x, ..., main, type=c("l", "b"), grid=TRUE, ngrid=10, col.grid="grey", col.base="white", win.args=list(), spike.args=list(), neg.args=list(), point.args=list(), which.marks=1, zlab=NULL, zlim=NULL, zadjust=1, legend=TRUE, legendpos="bottomleft", leg.args=list(lwd=4), leg.col=c("black", "orange")) { if(missing(main)) main <- short.deparse(substitute(x)) type <- match.arg(type) W <- Window(x) R <- Frame(x) marx <- marks(x) dotargs <- list(...) #' ensure numeric marks mf <- markformat(marx) switch(mf, none = { stop("point pattern must have marks", call.=FALSE) }, vector = { if(is.null(zlab)) zlab <- "mark" }, dataframe = { if(missing(which.marks)) { marx <- numeric.columns(marx) } cn <- colnames(marx) stopifnot(length(which.marks) == 1) if(is.character(which.marks)) { k <- match(which.marks, cn) if(is.na(k)) stop(paste("unrecognised selection of mark column", sQuote(which.marks)), call.=FALSE) which.marks <- k } if(missing(zlab)) zlab <- colnames(marx)[which.marks] marx <- marx[,which.marks] }, stop("marks should be a vector or a data frame", call.=FALSE) ) marx <- as.numeric(marx) if(is.null(zlim)) zlim <- range(marx, 0) check.range(zlim) #' rescale marks to a scale commensurate with window #' (to achieve appropriate default scale in persp.default) maxmark <- max(abs(marx)) if(maxmark > .Machine$double.eps) { scal <- max(sidelengths(R))/maxmark scaled.marx <- scal * marx scaled.zlim <- scal * zlim } else { scaled.marx <- marx scaled.zlim <- zlim } #' Set up objects to be plotted in perspective Rplus <- grow.rectangle(R, fraction=1/(2*ngrid)) #' base plane image Z <- as.im(0, W=Rplus, dimyx=rev(ngrid)+1) #' spikes S <- xyzsegmentdata(x$x, x$y, 0, x$x, x$y, scaled.marx) #' bubbles if(type == "b") P <- data.frame(x=x$x, y=x$y, z=scaled.marx) #' Assemble arguments for persp.default col.grid.used <- if(grid && (zlim[1] >= 0)) col.grid else NA if(!is.na(k <- match("adj.main", names(dotargs)))) names(dotargs)[k] <- "adj" argh <- resolve.defaults(list(x=Z, main=main, border=col.grid.used, col=col.base), dotargs, list(axes=FALSE, box=FALSE, zlim=scaled.zlim, zlab=zlab, #' do not independently rescale x & y scale=FALSE, #' expand=0.1 is default in persp.default expand=zadjust * 0.1)) #' Start perspective plot; plot horizontal plane M <- do.call.matched(persp.im, argh, funargs=graphicsPars("persp")) #' Start drawing objects if(grid) { if(scaled.zlim[1] < 0) { #' first draw downward spikes downward <- (scaled.marx < 0) if(any(downward)) { SD <- S[downward, , drop=FALSE] spectiveSegments(SD, neg.args, spike.args, dotargs, M=M) S <- S[!downward, , drop=FALSE] if(type == "b") { PD <- P[downward, , drop=FALSE] spectivePoints(PD, point.args, dotargs, M=M) P <- P[!downward, , drop=FALSE] } } #' plot baseline grid spectiveFlatGrid(R, ngrid, M, col=col.grid) } } if(!is.rectangle(W)) { #' plot window spectiveFlatPolygons(W, M, win.args, dotargs) } #' draw upward spikes if(nrow(S) > 0) { spectiveSegments(S, spike.args, dotargs, M=M) if(type == "b") spectivePoints(P, point.args, dotargs, M=M) } #' if(legend) { #' draw a reference scale as another spike #' determine spike position if(is.character(legendpos)) { legendpos <- match.arg(legendpos, c("bottomleft", "bottomright", "topleft", "topright", "bottom", "left", "top", "right")) B <- Frame(x) xr <- B$xrange yr <- B$yrange legxy <- switch(legendpos, bottomleft = c(xr[1], yr[1]), bottomright = c(xr[2], yr[1]), topleft = c(xr[1], yr[2]), topright = c(xr[2], yr[2]), bottom = c(mean(xr), yr[1]), left = c(xr[1], mean(yr)), top = c(mean(xr), yr[2]), right = c(xr[2], mean(yr))) } else legxy <- ensure2vector(unlist(legendpos)) #' determine tickmarks tix <- unique(sort(c(zlim, prettyinside(zlim)))) ntix <- length(tix) scaled.tix <- scal * tix tixseg <- xyzsegmentdata(legxy[1], legxy[2], scaled.tix[-ntix], legxy[1], legxy[2], scaled.tix[-1]) tixcol <- rep(leg.col, ntix)[1:ntix] spectiveSegments(tixseg, list(col=tixcol), leg.args, M=M) spectiveText(legxy[1], legxy[2], scaled.tix[-c(1,ntix)], labels=tix[-c(1,ntix)], pos=4, M=M) } invisible(M) } xyzsegmentdata <- function(x0, y0, z0, x1, y1, z1) { data.frame(x0=x0, y0=y0, z0=z0, x1=x1, y1=y1, z1=z1) } trans3dz <- function(x,y,z,pmat) { tr <- cbind(x, y, z, 1) %*% pmat list(x = tr[, 1]/tr[, 4], y = tr[, 2]/tr[, 4], z = tr[, 3]/tr[, 4]) } spectiveFlatGrid <- function(B, ngrid, M, ...) { ## arguments ... should be lists of parameters B <- Frame(B) xr <- B$xrange yr <- B$yrange ngrid <- ensure2vector(ngrid) xx <- seq(xr[1], xr[2], length.out=ngrid[1]+1) yy <- seq(yr[1], yr[2], length.out=ngrid[2]+1) horiz <- xyzsegmentdata(xr[1], yy, 0, xr[2], yy, 0) vert <- xyzsegmentdata(xx, yr[1], 0, xx, yr[2], 0) spectiveSegments(horiz, ..., M=M) spectiveSegments(vert, ..., M=M) invisible(NULL) } spectiveFlatPolygons <- function(W, M, ...) { ## arguments ... should be lists of parameters Wbdry <- as.polygonal(W)$bdry Pbdry <- lapply(Wbdry, function(p, M) { as.list(trans3dz(p$x, p$y, 0, M))[c("x","y")] }, M=M) P <- owin(poly=Pbdry, check=FALSE, fix=FALSE) do.call(plot.owin, resolve.defaults(list(quote(P)), ..., list(add=TRUE))) } spectiveSegments <- function(df, ..., M) { ## arguments ... should be lists of parameters a0 <- with(df, trans3dz(x0, y0, z0, M)) a1 <- with(df, trans3dz(x1, y1, z1, M)) do.call.matched(segments, resolve.defaults( list(x0=a0$x, y0=a0$y, x1=a1$x, y1=a1$y), ...)) invisible(NULL) } spectivePoints <- function(df, ..., M) { ## arguments ... should be lists of parameters p <- with(df, trans3dz(x, y, z, M)) do.call.matched(points.default, resolve.defaults( list(x=p$x, y=p$y), ...), extrargs=graphicsPars("points")) } spectiveText <- function(x,y,z, ..., M) { p <- trans3dz(x, y, z, M) text(p$x, p$y, ...) } persp.ppp }) spatstat.geom/R/plot.owin.R0000644000176200001440000002701614614353221015327 0ustar liggesusers# # plot.owin.S # # The 'plot' method for observation windows (class "owin") # # $Revision: 1.64 $ $Date: 2024/05/01 05:43:30 $ # # # plot.owin <- function(x, main, add=FALSE, ..., box, edge=0.04, type = c("w", "n"), show.all=!add, hatch=FALSE, hatchargs=list(), invert=FALSE, do.plot=TRUE, claim.title.space=FALSE, use.polypath=TRUE, adj.main=0.5) { # # Function plot.owin. A method for plot. # if(missing(main)) main <- short.deparse(substitute(x)) W <- x verifyclass(W, "owin") if(!do.plot) return(invisible(as.rectangle(W))) type <- match.arg(type) if(missing(box) || is.null(box)) { box <- is.mask(W) && show.all } else stopifnot(is.logical(box) && length(box) == 1) #### pt <- prepareTitle(main) main <- pt$main nlines <- pt$nlines ######### xlim <- xr <- W$xrange ylim <- yr <- W$yrange #################################################### ## graphics parameters that can be overridden by user gparam <- resolve.defaults(list(...), par()) ## character expansion factors ## main title size = 'cex.main' * par(cex.main) * par(cex) ## user's graphics expansion factor (*multiplies* par) cex.main.user <- resolve.1.default(list(cex.main=1), list(...)) ## size of main title as multiple of par('cex') cex.main.rela <- cex.main.user * par('cex.main') ## absolute size cex.main.absol <- cex.main.rela * par('cex') if(!add) { ## new plot if(claim.title.space && nlines > 0) { ## allow space for main title (only in multi-panel plots) guesslinespace <- 0.07 * sqrt(diff(xr)^2 + diff(yr)^2) * cex.main.absol added <- (nlines + 1) * guesslinespace ylim[2] <- ylim[2] + added } ## set up plot with equal scales do.call.plotfun(plot.default, resolve.defaults(list(x=numeric(0), y=numeric(0), type="n"), list(...), list(xlim=xlim, ylim=ylim, ann=FALSE, axes=FALSE, asp=1.0, xaxs="i", yaxs="i", xlab="", ylab=""), .MatchNull=FALSE)) } if(show.all && nlines > 0) { ## add title if(!missing(adj.main)) { check.1.real(adj.main) stopifnot(adj.main %in% c(0, 0.5, 1)) } if(claim.title.space) { mainheight <- sum(strheight(main, units="user", cex=cex.main.rela)) gapheight <- (strheight("b\nb", units="user", cex=cex.main.rela) - 2 * strheight("b", units="user", cex=cex.main.rela)) if(nlines > 1 && !is.expression(main)) main <- paste(main, collapse="\n") xpos <- xr[1] + adj.main * diff(xr) text(x=xpos, y=yr[2] + mainheight + 0.5 * gapheight, labels=main, adj=adj.main, cex=cex.main.rela, col=gparam$col.main, font=gparam$font.main) } else { title(main=main, cex=cex.main.rela, col=gparam$col.main, font=gparam$font.main, adj=adj.main) } } # Draw surrounding box if(box) do.call.plotfun(segments, resolve.defaults( list(x0=xr[c(1,2,2,1)], y0=yr[c(1,1,2,2)], x1=xr[c(2,2,1,1)], y1=yr[c(1,2,2,1)]), list(...))) # If type = "n", do not plot the window. if(type == "n") return(invisible(as.rectangle(W))) # Draw window switch(W$type, rectangle = { Wpoly <- as.polygonal(W) po <- Wpoly$bdry[[1]] dont.complain.about(po) do.call.plotfun(polygon, resolve.defaults(list(x=quote(po)), list(...)), extrargs="lwd") if(hatch) do.call(add.texture, append(list(W=quote(W)), hatchargs)) }, polygonal = { p <- W$bdry # Determine whether user wants to fill the interior col.poly <- resolve.defaults(list(...), list(col=NA))$col den.poly <- resolve.defaults(list(...), list(density=NULL))$density no.fill <- is.null(den.poly) && (is.null(col.poly) || is.na(col.poly)) # Determine whether we need to triangulate the interior. # If it is required to fill the interior, # this can be done directly using polygon() provided # there are no holes. Otherwise we must triangulate the interior. if(no.fill) triangulate <- FALSE else { # Determine whether there are any holes holes <- unlist(lapply(p, is.hole.xypolygon)) triangulate <- any(holes) } if(!triangulate) { # No triangulation required; # simply plot the polygons for(i in seq_along(p)) { p.i <- p[[i]] dont.complain.about(p.i) do.call.plotfun(polygon, resolve.defaults( list(x=quote(p.i)), list(...)), extrargs="lwd") } } else { # Try using polypath(): if(use.polypath && !(names(dev.cur()) %in% c("xfig","pictex","X11"))) { ppa <- owin2polypath(W) do.call.plotfun(polypath, resolve.defaults(ppa, list(border=col.poly), list(...))) } else { # decompose window into simply-connected pieces broken <- try(break.holes(W)) if(inherits(broken, "try-error")) { warning("Unable to plot filled polygons") } else { # Fill pieces with colour (and draw border in same colour) pp <- broken$bdry for(i in seq_len(length(pp))) { ppi <- pp[[i]] dont.complain.about(ppi) do.call.plotfun(polygon, resolve.defaults(list(x=quote(ppi), border=col.poly), list(...))) } } } # Now draw polygon boundaries for(i in seq_along(p)) { p.i <- p[[i]] dont.complain.about(p.i) do.call.plotfun(polygon, resolve.defaults( list(x=quote(p.i)), list(density=0, col=NA), list(...)), extrargs="lwd") } } if(hatch) do.call(add.texture, append(list(W=quote(W)), hatchargs)) }, mask = { # capture 'col' argument and ensure it's at least 2 values coldefault <- c(par("bg"), par("fg")) col <- resolve.defaults( list(...), spatstat.options("par.binary"), list(col=coldefault) )$col if(length(col) == 1) { col <- unique(c(par("bg"), col)) if(length(col) == 1) col <- c(par("fg"), col) } ## invert colours? if(invert) col <- rev(col) ## convert to greyscale? if(spatstat.options("monochrome")) col <- to.grey(col) xcol <- W$xcol yrow <- W$yrow zmat <- t(W$m) dont.complain.about(xcol, yrow, zmat) do.call.matched(image.default, resolve.defaults( list(x=quote(xcol), y=quote(yrow), z=quote(zmat), add=TRUE), list(col=col), list(...), spatstat.options("par.binary"), list(zlim=c(FALSE, TRUE)))) if(hatch) do.call(add.texture, append(list(W=quote(W)), hatchargs)) }, stop(paste("Don't know how to plot window of type", sQuote(W$type))) ) return(invisible(as.rectangle(W))) } break.holes <- local({ insect <- function(A, Box) { ## efficient version of intersect.owin which doesn't 'fix' the polygons a <- lapply(A$bdry, reverse.xypolygon) b <- lapply(as.polygonal(Box)$bdry, reverse.xypolygon) ab <- polyclip::polyclip(a, b, "intersection", fillA="nonzero", fillB="nonzero") if(length(ab)==0) return(emptywindow(Box)) # ensure correct polarity totarea <- sum(unlist(lapply(ab, Area.xypolygon))) if(totarea < 0) ab <- lapply(ab, reverse.xypolygon) AB <- owin(Box$xrange, Box$yrange, poly=ab, check=FALSE, strict=FALSE, fix=FALSE, unitname=unitname(A)) return(AB) } break.holes <- function(x, splitby=NULL, depth=0, maxdepth=100) { if(is.null(splitby)) { ## first call: validate x stopifnot(is.owin(x)) splitby <- "x" } if(depth > maxdepth) stop("Unable to divide window into simply-connected pieces") p <- x$bdry holes <- unlist(lapply(p, is.hole.xypolygon)) if(!any(holes)) return(x) nholes <- sum(holes) maxdepth <- max(maxdepth, 4 * nholes) i <- min(which(holes)) p.i <- p[[i]] b <- as.rectangle(x) xr <- b$xrange yr <- b$yrange switch(splitby, x = { xsplit <- mean(range(p.i$x)) left <- c(xr[1], xsplit) right <- c(xsplit, xr[2]) xleft <- insect(x, owinInternalRect(left, yr)) xright <- insect(x, owinInternalRect(right, yr)) ## recurse xleft <- break.holes(xleft, splitby="y", depth=depth+1, maxdepth=maxdepth) xright <- break.holes(xright, splitby="y", depth=depth+1, maxdepth=maxdepth) ## recombine (without fusing polygons again!) result <- owin(xr, yr, poly=c(xleft$bdry, xright$bdry), check=FALSE, strict=FALSE, fix=FALSE) }, y = { ysplit <- mean(range(p.i$y)) lower <- c(yr[1], ysplit) upper <- c(ysplit, yr[2]) xlower <- insect(x, owinInternalRect(xr, lower)) xupper <- insect(x, owinInternalRect(xr, upper)) ## recurse xlower <- break.holes(xlower, splitby="x", depth=depth+1, maxdepth=maxdepth) xupper <- break.holes(xupper, splitby="x", depth=depth+1, maxdepth=maxdepth) ## recombine (without fusing polygons again!) result <- owin(xr, yr, poly=c(xlower$bdry, xupper$bdry), check=FALSE, strict=FALSE, fix=FALSE) }) return(result) } break.holes }) spatstat.geom/R/disc.R0000644000176200001440000000733614611065351014324 0ustar liggesusers## ## disc.R ## ## discs and ellipses ## ## $Revision: 1.22 $ $Date: 2024/02/04 08:04:51 $ ## disc <- local({ indic <- function(x,y,x0,y0,r) { as.integer((x-x0)^2 + (y-y0)^2 < r^2) } disc <- function(radius=1, centre=c(0,0), ..., mask=FALSE, npoly=128, delta=NULL, metric=NULL) { check.1.real(radius) stopifnot(radius > 0) centre <- as2vector(centre) if(!is.null(metric)) { W <- invoke.metric(metric, "disc", radius=radius, centre=centre, mask=mask, npoly=npoly, delta=delta) return(W) } if(!missing(npoly) && !is.null(npoly) && !is.null(delta)) stop("Specify either npoly or delta") if(!missing(npoly) && !is.null(npoly)) { stopifnot(length(npoly) == 1) stopifnot(npoly >= 3) } else if(!is.null(delta)) { check.1.real(delta) stopifnot(delta > 0) npoly <- pmax(16, ceiling(2 * pi * radius/delta)) } else npoly <- 128 if(!mask) { theta <- seq(from=0, to=2*pi, length.out=npoly+1)[-(npoly+1L)] x <- centre[1L] + radius * cos(theta) y <- centre[2L] + radius * sin(theta) W <- owin(poly=list(x=x, y=y), check=FALSE) } else { xr <- centre[1L] + radius * c(-1,1) yr <- centre[2L] + radius * c(-1,1) B <- owinInternalRect(xr,yr) IW <- as.im(indic, B, x0=centre[1L], y0=centre[2L], r=radius, ...) W <- levelset(IW, 1, "==") } return(W) } disc }) hexagon <- function(edge=1, centre=c(0,0), ..., align=c("bottom", "top", "left", "right", "no")) { regularpolygon(6, edge, centre, align=align) } regularpolygon <- function(n, edge=1, centre=c(0,0), ..., align=c("bottom", "top", "left", "right", "no")) { check.1.integer(n) check.1.real(edge) stopifnot(n >= 3) stopifnot(edge > 0) align <- match.arg(align) theta <- 2 * pi/n radius <- edge/(2 * sin(theta/2)) result <- disc(radius, centre, npoly=n, mask=FALSE) if(align != "no") { k <- switch(align, bottom = 3/4, top = 1/4, left = 1/2, right = 1) alpha <- theta * (1/2 - (k * n) %% 1) result <- rotate(result, -alpha) } Frame(result) <- boundingbox(result) return(result) } ellipse <- local({ indic <- function(x,y,x0,y0,a,b,co,si){ x <- x-x0 y <- y-y0 as.integer(((x*co + y*si)/a)^2 + ((-x*si + y*co)/b)^2 < 1) } ellipse <- function(a, b, centre=c(0,0), phi=0, ..., mask=FALSE, npoly = 128) { ## Czechs: stopifnot(length(a) == 1) stopifnot(a > 0) stopifnot(length(b) == 1) stopifnot(b > 0) centre <- as2vector(centre) stopifnot(length(phi) == 1) stopifnot(length(npoly) == 1) stopifnot(npoly > 2) ## Rotator cuff: co <- cos(phi) si <- sin(phi) ## Mask: if(mask) { ## Thetas maximizing x and y. tx <- atan(-b*tan(phi)/a) ty <- atan(b/(a*tan(phi))) ## Maximal x and y (for centre = c(0,0)). xm <- a*co*cos(tx) - b*si*sin(tx) ym <- a*si*cos(ty) + b*co*sin(ty) ## Range of x and y. xr <- xm*c(-1,1)+centre[1L] yr <- ym*c(-1,1)+centre[2L] ## Wrecked-angle to contain the mask. B <- as.mask(owinInternalRect(xr,yr),...) ## Build the mask as a level set. IW <- as.im(indic, B, x0=centre[1L], y0=centre[2L], a=a, b=b, co=co, si=si) return(levelset(IW, 1, "==")) } ## Polygonal. ## Build "horizontal" ellipse centred at 0: theta <- seq(0, 2 * pi, length = npoly+1)[-(npoly+1L)] xh <- a * cos(theta) yh <- b * sin(theta) ## Rotate through angle phi and shift centre: x <- centre[1L] + co*xh - si*yh y <- centre[2L] + si*xh + co*yh owin(poly=list(x = x, y = y)) } ellipse }) spatstat.geom/R/funxy.R0000644000176200001440000001165714611065352014555 0ustar liggesusers# # funxy.R # # Class of functions of x,y location with a spatial domain # # $Revision: 1.24 $ $Date: 2023/05/02 04:47:26 $ # spatstat.xy.coords <- function(x,y) { if(missing(y) || is.null(y)) { xy <- if(is.ppp(x) || is.lpp(x) || is.quad(x)) coords(x) else if(checkfields(x, c("x", "y"))) x else stop("Argument y is missing", call.=FALSE) x <- xy$x y <- xy$y } xy.coords(x,y)[c("x","y")] } funxy <- function(f, W=NULL) { stopifnot(is.function(f)) stopifnot(is.owin(W)) if(!identical(names(formals(f))[1:2], c("x", "y"))) stop("The first two arguments of f should be named x and y", call.=FALSE) if(is.primitive(f)) stop("Not implemented for primitive functions", call.=FALSE) ## copy 'f' including formals, environment, attributes h <- f ## make new function body: ## paste body of 'f' into last line of 'spatstat.xy.coords' b <- body(spatstat.xy.coords) b[[length(b)]] <- body(f) ## transplant the body body(h) <- b ## reinstate attributes attributes(h) <- attributes(f) unitname(h) <- unitname(W) ## stamp it class(h) <- c("funxy", class(h)) attr(h, "W") <- W attr(h, "f") <- f return(h) } print.funxy <- function(x, ...) { nama <- names(formals(x)) splat(paste0("function", paren(paste(nama,collapse=","))), "of class", sQuote("funxy")) print(as.owin(x)) splat("\nOriginal function definition:") print(attr(x, "f")) } summary.funxy <- function(object, ...) { w <- Window(object) z <- list(argues = names(formals(object)), fundef = attr(object, "f"), values = summary(as.im(object, ...)), wintype = w$type, frame = Frame(w), units = unitname(w)) class(z) <- "summary.funxy" return(z) } print.summary.funxy <- function(x, ...) { sigdig <- getOption('digits') splat(paste0("function", paren(paste(x$argues,collapse=","))), "of class", sQuote("funxy")) windesc <- switch(x$wintype, rectangle="the rectangle", polygonal="a polygonal window inside the frame", mask="a binary mask in the rectangle") unitinfo <- summary(x$units) splat("defined in", windesc, prange(signif(x$frame$xrange, sigdig)), "x", prange(signif(x$frame$yrange, sigdig)), unitinfo$plural, unitinfo$explain ) splat("\nOriginal function definition:") print(x$fundef) v <- x$values splat("\nFunction values are", v$type) switch(v$type, integer=, real={ splat("\trange =", prange(signif(v$range, sigdig))) splat("\tintegral =", signif(v$integral, sigdig)) splat("\tmean =", signif(v$mean, sigdig)) }, factor={ print(v$table) }, complex={ splat("\trange: Real", prange(signif(v$Re$range, sigdig)), "Imaginary", prange(signif(v$Im$range, sigdig))) # splat("\tintegral =", signif(v$integral, sigdig)) splat("\tmean =", signif(v$mean, sigdig)) }, { print(v$summary) }) invisible(NULL) } as.owin.funxy <- function(W, ..., fatal=TRUE) { W <- attr(W, "W") as.owin(W, ..., fatal=fatal) } domain.funxy <- Window.funxy <- function(X, ...) { as.owin(X) } # Note that 'distfun' (and other classes inheriting from funxy) # has a method for as.owin that takes precedence over as.owin.funxy # and this will affect the behaviour of the following plot methods # because 'distfun' does not have its own plot method. plot.funxy <- function(x, ...) { xname <- short.deparse(substitute(x)) force(x) W <- as.owin(x) do.call(do.as.im, resolve.defaults(list(quote(x), action="plot"), list(...), list(main=xname, W=W))) invisible(NULL) } contour.funxy <- function(x, ...) { xname <- short.deparse(substitute(x)) force(x) W <- as.owin(x) do.call(do.as.im, resolve.defaults(list(quote(x), action="contour"), list(...), list(main=xname, W=W))) invisible(NULL) } persp.funxy <- function(x, ...) { xname <- short.deparse(substitute(x)) zlab <- substitute(expression(f(x,y)), list(f=as.name(xname))) force(x) W <- as.rectangle(as.owin(x)) do.call(do.as.im, resolve.defaults(list(quote(x), action="persp"), list(...), list(main=xname, W=W, zlab=zlab))) invisible(NULL) } hist.funxy <- function(x, ..., xname) { if(missing(xname) || is.null(xname)) xname <- short.deparse(substitute(x)) a <- do.call.matched(as.im, list(X=x, ...), c("X", "W", "dimyx", "eps", "xy", "rule.eps", "na.replace", "strict"), sieve=TRUE) Z <- a$result do.call(hist.im, append(list(x=Z, xname=xname), a$otherargs)) } spatstat.geom/R/is.subset.owin.R0000644000176200001440000000437014611065352016270 0ustar liggesusers# # is.subset.owin.R # # $Revision: 1.17 $ $Date: 2023/12/16 05:02:18 $ # # Determine whether a window is a subset of another window # # is.subset.owin() # is.subset.owin <- local({ is.subset.owin <- function(A, B) { A <- as.owin(A) B <- as.owin(B) if(identical(A, B)) return(TRUE) A <- rescue.rectangle(A) B <- rescue.rectangle(B) if(is.rectangle(B)) { # Some cases can be resolved using convexity of B # (1) A is also a rectangle if(is.rectangle(A)) { xx <- A$xrange[c(1L,2L,2L,1L)] yy <- A$yrange[c(1L,1L,2L,2L)] ok <- inside.owin(xx, yy, B) return(all(ok)) } # (2) A is polygonal # Then A is a subset of B iff, # for every constituent polygon of A with positive sign, # the vertices are all in B if(is.polygonal(A)) { ok <- unlist(lapply(A$bdry, okpolygon, B=B)) return(all(ok)) } # (3) Feeling lucky # Test whether the bounding box of A is a subset of B # Then a fortiori, A is a subset of B AA <- boundingbox(A) if(is.subset.owin(AA, B)) return(TRUE) } if(!is.mask(A) && !is.mask(B)) { ## rectangles or polygonal domains if(!all(inside.owin(vertices(A), , B))) return(FALSE) ## all vertices of A are inside B. if(is.convex(B)) return(TRUE) ## check whether the boundaries are disjoint if(!anycrossing.psp(edges(A), edges(B))) { ## Disjoint boundary crossings sufficient if B has no holes if(length(B$bdry) == 1 || !any(sapply(B$bdry, is.hole.xypolygon))) return(TRUE) ## Compare area of intersection with area of putative subset ## (use '>=' instead of '==' because of numerical rounding error) areaA <- area(A) if(overlap.owin(A,B) >= areaA || overlap.owin(B,A) >= areaA) return(TRUE) } ## continue... } # Discretise a <- as.mask(A) b <- as.mask(B) rxy <- rasterxy.mask(a, drop=TRUE) xx <- rxy$x yy <- rxy$y ok <- inside.owin(xx, yy, b) return(all(ok)) } okpolygon <- function(a, B) { if(Area.xypolygon(a) < 0) return(TRUE) ok <- inside.owin(a$x, a$y, B) return(all(ok)) } is.subset.owin }) spatstat.geom/R/polygood.R0000644000176200001440000001357614611065352015242 0ustar liggesusers#' #' polygood.R #' #' Check validity of polygon data #' #' $Revision: 1.5 $ $Date: 2024/02/04 08:04:51 $ #' #' check validity of a polygonal owin owinpolycheck <- function(W, verbose=TRUE) { verifyclass(W, "owin") stopifnot(W$type == "polygonal") # extract stuff B <- W$bdry npoly <- length(B) outerframe <- owinInternalRect(W$xrange, W$yrange) # can't use as.rectangle here; we're still checking validity boxarea.mineps <- area.owin(outerframe) * (1 - 0.00001) # detect very large datasets BS <- object.size(B) blowbyblow <- verbose && (BS > 1e4 || npoly > 20) # answer <- TRUE notes <- character(0) err <- character(0) # check for duplicated points, self-intersection, outer frame if(blowbyblow) { cat(paste("Checking", npoly, ngettext(npoly, "polygon...", "polygons..."))) pstate <- list() } dup <- self <- is.box <- logical(npoly) for(i in 1:npoly) { if(blowbyblow && npoly > 1L) pstate <- progressreport(i, npoly, state=pstate) Bi <- B[[i]] # check for duplicated vertices dup[i] <- as.logical(anyDuplicated(ppp(Bi$x, Bi$y, window=outerframe, check=FALSE))) if(dup[i] && blowbyblow) message(paste("Polygon", i, "contains duplicated vertices")) # check for self-intersection self[i] <- xypolyselfint(B[[i]], proper=TRUE, yesorno=TRUE) if(self[i] && blowbyblow) message(paste("Polygon", i, "is self-intersecting")) # check whether one of the current boundary polygons # is the bounding box itself (with + sign) is.box[i] <- (length(Bi$x) == 4) && (Area.xypolygon(Bi) >= boxarea.mineps) } if(blowbyblow) cat("done.\n") if((ndup <- sum(dup)) > 0) { whinge <- paste(ngettext(ndup, "Polygon", "Polygons"), if(npoly == 1L) NULL else commasep(which(dup)), ngettext(ndup, "contains", "contain"), "duplicated vertices") notes <- c(notes, whinge) err <- c(err, "duplicated vertices") if(verbose) message(whinge) answer <- FALSE } if((nself <- sum(self)) > 0) { whinge <- paste(ngettext(nself, "Polygon", "Polygons"), if(npoly == 1L) NULL else commasep(which(self)), ngettext(nself, "is", "are"), "self-intersecting") notes <- c(notes, whinge) if(verbose) message(whinge) err <- c(err, "self-intersection") answer <- FALSE } if(sum(is.box) > 1L) { answer <- FALSE whinge <- paste("Polygons", commasep(which(is.box)), "coincide with the outer frame") notes <- c(notes, whinge) err <- c(err, "polygons duplicating the outer frame") } # check for crossings between different polygons cross <- matrix(FALSE, npoly, npoly) if(npoly > 1L) { if(blowbyblow) { cat(paste("Checking for cross-intersection between", npoly, "polygons...")) pstate <- list() } P <- lapply(B, xypolygon2psp, w=outerframe, check=FALSE) for(i in seq_len(npoly-1L)) { if(blowbyblow) pstate <- progressreport(i, npoly-1L, state=pstate) Pi <- P[[i]] for(j in (i+1L):npoly) { crosses <- if(is.box[i] || is.box[j]) FALSE else { anycrossing.psp(Pi, P[[j]]) } cross[i,j] <- cross[j,i] <- crosses if(crosses) { answer <- FALSE whinge <- paste("Polygons", i, "and", j, "cross over") notes <- c(notes, whinge) if(verbose) message(whinge) err <- c(err, "overlaps between polygons") } } } if(blowbyblow) cat("done.\n") } err <- unique(err) attr(answer, "notes") <- notes attr(answer, "err") <- err return(answer) } #' check for self-intersections in an xypolygon xypolyselfint <- function(p, eps=.Machine$double.eps, proper=FALSE, yesorno=FALSE, checkinternal=FALSE) { verify.xypolygon(p) n <- length(p$x) verbose <- (n > 1000) if(verbose) cat(paste("[Checking polygon with", n, "edges...")) x0 <- p$x y0 <- p$y dx <- diff(x0[c(1:n,1L)]) dy <- diff(y0[c(1:n,1L)]) if(yesorno) { ## get a yes-or-no answer answer <- .C(SG_xypsi, n=as.integer(n), x0=as.double(x0), y0=as.double(y0), dx=as.double(dx), dy=as.double(dy), xsep=as.double(2 * max(abs(dx))), ysep=as.double(2 * max(abs(dy))), eps=as.double(eps), proper=as.integer(proper), answer=as.integer(integer(1L)), PACKAGE="spatstat.geom")$answer if(verbose) cat("]\n") return(answer != 0) } out <- .C(SG_Cxypolyselfint, n=as.integer(n), x0=as.double(x0), y0=as.double(y0), dx=as.double(dx), dy=as.double(dy), eps=as.double(eps), xx=as.double(numeric(n^2)), yy=as.double(numeric(n^2)), ti=as.double(numeric(n^2)), tj=as.double(numeric(n^2)), ok=as.integer(integer(n^2)), PACKAGE="spatstat.geom") uhoh <- (matrix(out$ok, n, n) != 0) if(proper) { # ignore cases where two vertices coincide ti <- matrix(out$ti, n, n)[uhoh] tj <- matrix(out$tj, n, n)[uhoh] i.is.vertex <- (abs(ti) < eps) | (abs(ti - 1) < eps) j.is.vertex <- (abs(tj) < eps) | (abs(tj - 1) < eps) dup <- i.is.vertex & j.is.vertex uhoh[uhoh] <- !dup } if(checkinternal && any(uhoh != t(uhoh))) warning("Internal error: incidence matrix is not symmetric") xx <- matrix(out$xx, n, n) yy <- matrix(out$yy, n, n) uptri <- (row(uhoh) < col(uhoh)) xx <- as.vector(xx[uhoh & uptri]) yy <- as.vector(yy[uhoh & uptri]) result <- list(x=xx, y=yy) if(verbose) cat("]\n") return(result) } spatstat.geom/R/exactPdt.R0000644000176200001440000000470614611065351015154 0ustar liggesusers# # exactPdt.R # R function exactPdt() for exact distance transform of binary mask # # $Revision: 4.23 $ $Date: 2022/05/21 09:52:11 $ # "exactPdt"<- function(w) { verifyclass(w, "owin") if(w$type != "mask") stop(paste("Input must be a window of type", sQuote("mask"))) ## nr <- w$dim[1L] nc <- w$dim[2L] xcol <- w$xcol yrow <- w$yrow ## handle empty window if(!any(w$m)) { dist <- matrix(Inf, nr, nc) rows <- cols <- matrix(NA_integer_ , nr, nc) bdist <- framedist.pixels(w, style="matrix") return(list(d=dist,row=rows,col=cols,b=bdist, w=w)) } # input image will be padded out with a margin of width 2 on all sides mr <- mc <- 2L # full dimensions of padded image Nnr <- nr + 2 * mr Nnc <- nc + 2 * mc N <- Nnr * Nnc # output image (subset): rows & columns (R indexing) rmin <- mr + 1L rmax <- Nnr - mr cmin <- mc + 1L cmax <- Nnc - mc ## do padding x <- matrix(FALSE, nrow=Nnr, ncol=Nnc) x[rmin:rmax, cmin:cmax] <- w$m res <- .C(SG_ps_exact_dt_R, as.double(xcol[1L]), as.double(yrow[1L]), as.double(xcol[nc]), as.double(yrow[nr]), nr = as.integer(nr), nc = as.integer(nc), mr = as.integer(mr), mc = as.integer(mc), inp = as.integer(t(x)), distances = as.double (double(N)), rows = as.integer(integer(N)), cols = as.integer(integer(N)), boundary = as.double (double(N)), PACKAGE="spatstat.geom") dist <- matrix(res$distances, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] rows <- matrix(res$rows, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] cols <- matrix(res$cols, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] bdist<- matrix(res$boundary, ncol=Nnc, nrow=Nnr, byrow = TRUE)[rmin:rmax, cmin:cmax] # convert from C to R indexing rows <- rows + 1L - as.integer(mr) cols <- cols + 1L - as.integer(mc) return(list(d=dist,row=rows,col=cols,b=bdist, w=w)) } project2set <- function(X, W, ...) { stopifnot(is.ppp(X)) W <- as.mask(W, ...) eW <- exactPdt(W) ## grid location of X XX <- nearest.raster.point(X$x, X$y, W) ijX <- cbind(XX$row, XX$col) ## look up values of 'eW' at this location iY <- eW$row[ijX] jY <- eW$col[ijX] ## convert to spatial coordinates Y <- ppp(W$xcol[jY], W$yrow[iY], window=W) return(Y) } spatstat.geom/R/plot3d.R0000644000176200001440000001651314611065352014605 0ustar liggesusers#' perspective plot of 3D #' #' $Revision: 1.9 $ $Date: 2023/02/28 01:54:11 $ #' project3Dhom <- local({ check3dvector <- function(x) { if(is.numeric(x) && length(x) == 3) return(NULL) xname <- short.deparse(substitute(x)) stop(paste(xname, "should be a numeric vector of length 3"), call.=FALSE) } normalise <- function(x) { len <- sqrt(sum(x^2)) if(len == 0) stop("Attempted to normalise a vector of length 0") return(x/len) } innerprod <- function(a, b) sum(a*b) crossprod <- function(u, v) { c(u[2] * v[3] - u[3] * v[2], -(u[1] * v[3] - u[3] * v[1]), u[1] * v[2] - u[2] * v[1]) } project3Dhom <- function(xyz, eye=c(0,-3,1), org=c(0,0,0), vert=c(0,0,1)) { ## xyz: data to be projected (matrix n * 3) stopifnot(is.matrix(xyz) && ncol(xyz) == 3) ## eye: eye position (x,y,z) check3dvector(eye) ## org: origin (x,y,z) becomes middle of projection plane check3dvector(org) ## vert: unit vector in direction to become the 'vertical' if(!missing(vert)) { check3dvector(vert) vert <- normalise(vert) } ## vector pointing into screen vin <- normalise(org - eye) ## projection of vertical onto screen vup <- normalise(vert - innerprod(vert, vin) * vin) ## horizontal axis in screen vhoriz <- crossprod(vin, vup) ## # dbg <- FALSE # if(dbg) { # cat("vin=") # print(vin) # cat("vup=") # print(vup) # cat("vhoriz=") # print(vhoriz) # } ## homogeneous coordinates hom <- t(t(xyz) - eye) %*% cbind(vhoriz, vup, vin) colnames(hom) <- c("x", "y", "d") return(hom) } project3Dhom }) plot3Dpoints <- local({ plot3Dpoints <- function(xyz, eye=c(2,-3,2), org=c(0,0,0), ..., type=c("p", "n", "h"), xlim=c(0,1), ylim=c(0,1), zlim=c(0,1), add=FALSE, box=TRUE, main, cex=par('cex'), box.back=list(col="pink"), box.front=list(col="blue", lwd=2) ) { if(missing(main)) main <- short.deparse(substitute(xyz)) type <- match.arg(type) #' if(is.null(box.back) || (is.logical(box.back) && box.back)) box.back <- list(col="pink") if(is.null(box.front) || (is.logical(box.front) && box.front)) box.front <- list(col="blue", lwd=2) stopifnot(is.list(box.back) || is.logical(box.back)) stopifnot(is.list(box.front) || is.logical(box.front)) #' stopifnot(is.matrix(xyz) && ncol(xyz) == 3) if(nrow(xyz) > 0) { if(missing(xlim)) xlim <- range(pretty(xyz[,1])) if(missing(ylim)) ylim <- range(pretty(xyz[,2])) if(missing(zlim)) zlim <- range(pretty(xyz[,3])) if(missing(org)) org <- c(mean(xlim), mean(ylim), mean(zlim)) } if(!add) { #' initialise plot bb <- plot3Dbox(xlim, ylim, zlim, eye=eye, org=org, do.plot=FALSE) plot(bb$xlim, bb$ylim, axes=FALSE, asp=1, type="n", xlab="", ylab="", main=main) } if(is.list(box.back)) { #' plot rear of box do.call(plot3DboxPart, resolve.defaults(list(xlim=xlim, ylim=ylim, zlim=zlim, eye=eye, org=org, part="back"), box.back, list(...))) } if(type != "n") { #' plot points uv <- project3Dhom(xyz, eye=eye, org=org) uv <- as.data.frame(uv) dord <- order(uv$d, decreasing=TRUE) uv <- uv[dord, , drop=FALSE] #' capture graphics arguments which might be vectors grarg <- list(..., cex=cex) grarg <- grarg[names(grarg) %in% parsAll] if(any(lengths(grarg) > 1L)) { grarg <- as.data.frame(grarg, stringsAsFactors=FALSE) grarg <- grarg[dord, , drop=FALSE] grarg <- as.list(grarg) } #' draw segments if(type == "h") { xy0 <- cbind(xyz[,1:2,drop=FALSE], zlim[1]) uv0 <- as.data.frame(project3Dhom(xy0, eye=eye, org=org)) uv0 <- uv0[dord, , drop=FALSE] segargs <- grarg[names(grarg) %in% parsSegments] do.call(segments, append(list(x0=with(uv0, x/d), y0=with(uv0, y/d), x1=with(uv, x/d), y1=with(uv, y/d)), segargs)) } #' draw points ptargs <- grarg[names(grarg) %in% parsPoints] ptargs$cex <- ptargs$cex * with(uv, min(d)/d) do.call(points, c(list(x=with(uv, x/d), y=with(uv, y/d)), ptargs)) } if(is.list(box.front)) do.call(plot3DboxPart, resolve.defaults(list(xlim=xlim, ylim=ylim, zlim=zlim, eye=eye, org=org, part="front"), box.front, list(...))) return(invisible(NULL)) } vertexind <- data.frame(i=rep(1:2,4), j=rep(rep(1:2,each=2),2), k=rep(1:2, each=4)) edgepairs <- data.frame(from=c(1, 1, 2, 3, 1, 2, 5, 3, 5, 4, 6, 7), to = c(2, 3, 4, 4, 5, 6, 6, 7, 7, 8, 8, 8)) vertexfrom <- vertexind[edgepairs$from,] vertexto <- vertexind[edgepairs$to,] parsPoints <- c("cex", "col", "fg", "bg", "pch", "lwd") parsSegments <- c("col", "lwd", "lty") parsAll <- union(parsPoints, parsSegments) hamming <- function(a, b) sum(abs(a-b)) ## determine projected positions of box vertices ## and optionally plot the box plot3Dbox <- function(xlim=c(0,1), ylim=xlim, zlim=ylim, eye=c(0,-3,1), org=c(0,0,0), do.plot=TRUE) { fromxyz <- with(vertexfrom, cbind(xlim[i], ylim[j], zlim[k])) toxyz <- with(vertexto, cbind(xlim[i], ylim[j], zlim[k])) fromuv <- project3Dhom(fromxyz, eye=eye, org=org) touv <- project3Dhom(toxyz, eye=eye, org=org) xfrom <- fromuv[,1]/fromuv[,3] xto <- touv[,1]/touv[,3] yfrom <- fromuv[,2]/fromuv[,3] yto <- touv[,2]/touv[,3] if(do.plot) segments(xfrom, yfrom, xto, yto) return(invisible(list(xlim=range(xfrom, xto), ylim=range(yfrom, yto)))) } ## plot either back or front of box plot3DboxPart <- function(xlim=c(0,1), ylim=xlim, zlim=ylim, eye=c(0,-3,1), org=c(0,0,0), part=c("front", "back"), ...) { part <- match.arg(part) boxvert <- with(vertexind, cbind(xlim[i], ylim[j], zlim[k])) pvert <- project3Dhom(boxvert, eye=eye, org=org) xyvert <- pvert[,c("x","y")]/pvert[,"d"] ## find vertex which is furthest away nback <- which.max(pvert[,"d"]) nearback <- with(edgepairs, (from==nback) | (to==nback)) ind <- if(part == "back") nearback else !nearback ## draw lines with(edgepairs[ind,], do.call.matched(segments, list(x0=xyvert[from, 1], y0=xyvert[from, 2], x1=xyvert[to, 1], y1=xyvert[to, 2], ...))) } plot3Dpoints }) spatstat.geom/R/distfun.R0000644000176200001440000001527114611065351015053 0ustar liggesusers# # distfun.R # # distance function (returns a function of x,y) # # $Revision: 1.29 $ $Date: 2023/05/02 04:46:55 $ # distfun <- function(X, ...) { UseMethod("distfun") } distfun.ppp <- function(X, ..., k=1, undef=Inf) { # this line forces X to be bound stopifnot(is.ppp(X)) stopifnot(length(k) == 1) force(undef) g <- function(x,y=NULL) { Y <- xy.coords(x, y)[c("x", "y")] if(npoints(X) < k) rep(undef, length(Y$x)) else nncross(Y, X, what="dist", k=k) } attr(g, "Xclass") <- "ppp" g <- funxy(g, as.rectangle(as.owin(X))) attr(g, "k") <- k attr(g, "extrargs") <- list(k=k, undef=undef) class(g) <- c("distfun", class(g)) return(g) } distfun.psp <- function(X, ...) { # this line forces X to be bound stopifnot(is.psp(X)) g <- function(x,y=NULL) { Y <- xy.coords(x, y)[c("x", "y")] nncross(Y, X, what="dist") } attr(g, "Xclass") <- "psp" g <- funxy(g, as.rectangle(as.owin(X))) class(g) <- c("distfun", class(g)) attr(g, "extrargs") <- list() return(g) } distfun.owin <- function(X, ..., invert=FALSE) { # this line forces X to be bound stopifnot(is.owin(X)) force(invert) # P <- edges(X) # g <- function(x,y=NULL) { Y <- xy.coords(x, y) inside <- inside.owin(Y$x, Y$y, X) D <- nncross(Y, P, what="dist") out <- if(!invert) ifelseAX(inside, 0, D) else ifelseXB(inside, D, 0) return(out) } attr(g, "Xclass") <- "owin" g <- funxy(g, as.rectangle(as.owin(X))) attr(g, "extrargs") <- list(invert=invert) class(g) <- c("distfun", class(g)) return(g) } as.owin.distfun <- function(W, ..., fatal=TRUE) { X <- get("X", envir=environment(W)) result <- if(is.owin(X)) as.rectangle(X) else as.owin(X, ..., fatal=fatal) return(result) } domain.distfun <- Window.distfun <- function(X, ...) { as.owin(X) } as.im.distfun <- function(X, W=NULL, ..., eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, approx=TRUE) { k <- attr(X, "k") rule.eps <- match.arg(rule.eps) if(approx && is.null(W) && (is.null(k) || (k == 1))) { # use 'distmap' for speed env <- environment(X) Xdata <- get("X", envir=env) args <- list(X=Xdata, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps) if(is.owin(Xdata)) { args <- append(args, list(invert = get("invert", envir=env))) } D <- do.call(distmap, args = args) if(!is.null(na.replace)) D$v[is.null(D$v)] <- na.replace } else if(identical(attr(X, "Xclass"), "ppp")) { # point pattern --- use nngrid/knngrid env <- environment(X) Xdata <- get("X", envir=env) D <- nnmap(Xdata, W=W, what="dist", k=k, eps=eps, dimyx=dimyx, xy=xy, na.replace=na.replace, rule.eps=rule.eps, ...) } else { # evaluate function at pixel centres D <- as.im.function(X, W=W, eps=eps, dimyx=dimyx, xy=xy, rule.eps=rule.eps, na.replace=na.replace) } return(D) } print.distfun <- function(x, ...) { xtype <- attr(x, "Xclass") typestring <- switch(xtype, ppp="point pattern", psp="line segment pattern", owin="window", "unrecognised object") objname <- switch(xtype, ppp="point", psp="line segment", "object") splat("Distance function for", typestring) X <- get("X", envir=environment(x)) print(X) if(!is.null(k <- attr(x, "k")) && k > 1) splat("Distance to", ordinal(k), "nearest", objname, "will be computed") return(invisible(NULL)) } summary.distfun <- function(object, ...) { xtype <- attr(object, "Xclass") w <- as.owin(object) fundef <- attr(object, "f") attr(fundef, "Xclass") <- NULL X <- get("X", envir=environment(object)) z <- list(xtype = xtype, k = attr(object, "k") %orifnull% 1, Xsumry = summary(X), values = summary(as.im(object, ...)), wintype = w$type, frame = Frame(w), units = unitname(w)) class(z) <- "summary.distfun" return(z) } print.summary.distfun <- function(x, ...) { typestring <- switch(x$xtype, ppp="point pattern", psp="line segment pattern", owin="window", "unrecognised object") objname <- switch(x$xtype, ppp="point", psp="line segment", "object") splat("Distance function for", typestring) if(x$k > 1) splat("Distance to", ordinal(x$k), "nearest", objname, "will be computed") windesc <- switch(x$wintype, rectangle="the rectangle", polygonal="a polygonal window inside the frame", mask="a binary mask in the rectangle") unitinfo <- summary(x$units) sigdig <- getOption('digits') splat("defined in", windesc, prange(signif(x$frame$xrange, sigdig)), "x", prange(signif(x$frame$yrange, sigdig)), unitinfo$plural, unitinfo$explain ) v <- x$values splat("\nDistance function values:") splat("\trange =", prange(signif(v$range, sigdig))) # splat("\tintegral =", signif(v$integral, sigdig)) splat("\tmean =", signif(v$mean, sigdig)) invisible(NULL) } shift.distfun <- rotate.distfun <- scalardilate.distfun <- affine.distfun <- function(X, ...) { f <- X extrargs <- attr(f, "extrargs") if(is.null(extrargs)) stop(paste("distfun object has outdated format;", "cannot apply geometrical transformation"), call.=FALSE) Y <- get("X", envir=environment(f)) Ynew <- do.call(.Generic, list(Y, ...)) fnew <- do.call(distfun, append(list(Ynew), extrargs)) return(fnew) } flipxy.distfun <- reflect.distfun <- function(X) { f <- X extrargs <- attr(f, "extrargs") if(is.null(extrargs)) stop(paste("distfun object has outdated format;", "cannot apply geometrical transformation"), call.=FALSE) Y <- get("X", envir=environment(f)) Ynew <- do.call(.Generic, list(Y)) fnew <- do.call(distfun, append(list(Ynew), extrargs)) return(fnew) } rescale.distfun <- function(X, s, unitname) { if(missing(s)) s <- NULL if(missing(unitname)) unitname <- NULL f <- X Y <- get("X", envir=environment(f)) Ynew <- rescale(Y, s, unitname) extrargs <- attr(f, "extrargs") if(is.null(extrargs)) stop(paste("distfun object has outdated format;", "cannot rescale it"), call.=FALSE) fnew <- do.call(distfun, append(list(Ynew), extrargs)) return(fnew) } spatstat.geom/R/edit.R0000644000176200001440000000133314611065351014316 0ustar liggesusers## edit.R ## ## Methods for 'edit' ## ## $Revision: 1.3 $ $Date: 2015/04/19 06:14:21 $ edit.ppp <- local({ edit.ppp <- function(name, ...) { X <- name df <- as.data.frame(X) df <- as.data.frame(lapply(df, as.num.or.char)) Y <- edit(df, ...) Z <- as.ppp(Y, W=Window(X)) return(Z) } as.num.or.char <- function(x) { if (is.character(x)) x else if (is.numeric(x)) { storage.mode(x) <- "double" x } else as.character(x) } edit.ppp }) edit.im <- function(name, ...) { X <- name M <- transmat(as.matrix(X), from="spatstat", to="European") Y <- as.data.frame(M) Z <- edit(Y, ...) X[] <- transmat(as.matrix(Z), from="European", to="spatstat") return(X) } spatstat.geom/R/timed.R0000644000176200001440000000625114611065352014500 0ustar liggesusers#' #' timed.R #' #' Timed objects #' #' $Revision: 1.3 $ $Date: 2017/07/31 01:08:55 $ timed <- function(x, ..., starttime=NULL, timetaken=NULL) { if(is.null(starttime) && is.null(timetaken)) # time starts now. starttime <- proc.time() # evaluate expression if any object <- x if(is.null(timetaken)) timetaken <- proc.time() - starttime if(!inherits(object, "timed")) class(object) <- c("timed", class(object)) attr(object, "timetaken") <- timetaken return(object) } print.timed <- function(x, ...) { # strip the timing information and print the rest. taken <- attr(x, "timetaken") cx <- class(x) attr(x, "timetaken") <- NULL class(x) <- cx[cx != "timed"] NextMethod("print") # Now print the timing info cat(paste("\nTime taken:", codetime(taken), "\n")) return(invisible(NULL)) } timeTaken <- function(..., warn=TRUE) { allargs <- list(...) hastime <- sapply(allargs, inherits, what="timed") if(!any(hastime)) { if(warn) warning("Data did not contain timing information", call.=FALSE) return(NULL) } if(warn && !all(hastime)) warning("Some arguments did not contain timing information", call.=FALSE) times <- sapply(allargs[hastime], attr, which="timetaken") tottime <- rowSums(times) class(tottime) <- "proc_time" return(tottime) } #' .............. codetime .................................... #' Basic utility for converting times in seconds to text strings codetime <- local({ uname <- c("min", "hours", "days", "years", "thousand years", "million years", "billion years") u1name <- c("min", "hour", "day", "year", "thousand years", "million years", "billion years") multiple <- c(60, 60, 24, 365, 1e3, 1e3, 1e3) codehms <- function(x) { sgn <- if(x < 0) "-" else "" x <- round(abs(x)) hours <- x %/% 3600 mins <- (x %/% 60) %% 60 secs <- x %% 60 h <- if(hours > 0) paste(hours, ":", sep="") else "" started <- (hours > 0) m <- if(mins > 0) { paste(if(mins < 10 && started) "0" else "", mins, ":", sep="") } else if(started) "00:" else "" started <- started | (mins > 0) s <- if(secs > 0) { paste(if(secs < 10 && started) "0" else "", secs, sep="") } else if(started) "00" else "0" if(!started) s <- paste(s, "sec") paste(sgn, h, m, s, sep="") } codetime <- function(x, hms=TRUE, what=c("elapsed","user","system")) { if(inherits(x, "proc_time")) { what <- match.arg(what) x <- summary(x)[[match(what, c("user", "system", "elapsed"))]] } if(!is.numeric(x) || length(x) != 1) stop("codetime: x must be a proc_time object or a single number") sgn <- if(x < 0) "-" else "" x <- abs(x) if(x < 60) return(paste(sgn, signif(x, 3), " sec", sep="")) # more than 1 minute: round to whole number of seconds x <- round(x) if(hms && (x < 60 * 60 * 24)) return(paste(sgn, codehms(x), sep="")) u <- u1 <- "sec" for(k in seq_along(multiple)) { if(x >= multiple[k]) { x <- x/multiple[k] u <- uname[k] u1 <- u1name[k] } else break } xx <- round(x, 1) ux <- if(xx == 1) u1 else u paste(sgn, xx, " ", ux, sep="") } codetime }) spatstat.geom/R/tessfun.R0000644000176200001440000000421514765164672015102 0ustar liggesusers#' #' tessfun.R #' #' Functions which are constant on each tile of a tessellation #' #' Copyright (c) 2024 Adrian Baddeley, Tilman Davies and Martin Hazelton #' as.function.tess <- function(x, ..., values=NULL) { V <- x if(is.null(values)) { f <- function(x,y) { tileindex(x,y,V) } } else { if(is.data.frame(values)) values <- unlist(values) if(length(values) != nobjects(x)) stop("Length of 'values' should equal the number of tiles", call.=FALSE) values <- unname(values) f <- function(x,y) { values[as.integer(tileindex(x,y,V))] } } g <- funxy(f, Window(V)) class(g) <- c("tessfun", class(g)) return(g) } as.tess.tessfun <- function(X) { get("V", envir=environment(X)) } tessfunvalues <- function(f) { get("values", envir=environment(f)) %orifnull% seq_len(nobjects(as.tess(f))) } integral.tessfun <- function(f, domain=NULL, ...) { tes <- as.tess(f) val <- tessfunvalues(f) if(is.factor(val) || is.character(val)) stop(paste("Cannot integrate a function which returns", if(is.factor(val)) "factor" else "character", "values"), call.=FALSE) if(!is.complex(val)) val <- as.numeric(val) # need real or complex values if(!is.null(domain)) { marks(tes) <- val tes <- intersect.tess(tes, domain) val <- unlist(marks(tes)) } sum(tile.areas(tes) * val) } print.tessfun <- function(x, ...) { splat("Function which is constant on each tile of a tessellation") cat("\n") print.funxy(x, ...) cat("\n") print.tess(as.tess(x)) cat("\n") values <- tessfunvalues(x) if(is.factor(values)) { splat("Function values are categorical, with levels") print(levels(values)) } else { splat("Function values are of type", sQuote(typeof(values))) if(is.numeric(values)) splat("Range of function values:", prange(signif(range(values), 4))) } invisible(NULL) } plot.tessfun <- function(x, ...) { xname <- short.deparse(substitute(x)) tes <- as.tess(x) val <- tessfunvalues(x) do.call(plot.tess, resolve.defaults(list(quote(tes)), list(...), list(do.col=TRUE, values=val, main=xname))) } spatstat.geom/R/symbolmap.R0000644000176200001440000010273614721742046015412 0ustar liggesusers## ## symbolmap.R ## ## $Revision: 1.60 $ $Date: 2024/11/28 00:24:01 $ ## symbolmap <- local({ known.unknowns <- c("shape", "pch", "chars", "size", "cex", "direction", "arrowtype", "headlength", "headangle", "col", "cols", "fg", "bg", "lty", "lwd", "border", "fill", "etch") trycolourmap <- function(...) { try(colourmap(...), silent=TRUE) } symbolmap <- function(..., range=NULL, inputs=NULL) { if(!is.null(range) && !is.null(inputs)) stop("Arguments range and inputs are incompatible") ## graphics parameters parlist <- list(...) ## remove unrecognised parameters and NULL values if(length(parlist) > 0) { ok <- names(parlist) %in% known.unknowns ok <- ok & !unlist(lapply(parlist, is.null)) parlist <- parlist[ok] } got.pars <- (length(parlist) > 0) parnames <- names(parlist) type <- if(is.null(inputs) && is.null(range)) "constant" else if(!is.null(inputs)) "discrete" else "continuous" if(got.pars) { ## validate parameters if(is.null(parnames) || !all(nzchar(parnames))) stop("All graphics parameters must have names") atomic <- unlist(lapply(parlist, is.atomic)) functions <- unlist(lapply(parlist, is.function)) lenfs <- lengths(parlist) constants <- atomic & (lenfs == 1) if(any(bad <- !(constants | functions))) { if(type == "discrete" && any(repairable <- atomic & bad)) { ## recycle data to desired length parlist[repairable] <- lapply(parlist[repairable], reptolength, n=length(inputs)) bad[repairable] <- FALSE } if(type == "continuous") { ## look for vectors of colour values iscol <- bad & sapply(parlist, is.colour) & (names(parlist) %in% c("cols", "col", "fg", "bg")) ## convert colour values to colour map if(any(iscol)) { cmap <- lapply(parlist[iscol], trycolourmap, range=range) success <- sapply(cmap, inherits, what="colourmap") iscol[iscol] <- success if(any(iscol)) { parlist[iscol] <- cmap[success] bad[iscol] <- FALSE functions[iscol] <- TRUE } } } nbad <- sum(bad) if(nbad > 0) stop(paste(ngettext(nbad, "Argument", "Arguments"), commasep(sQuote(parnames[bad])), ngettext(nbad, "is neither a function nor a constant", "are neither functions nor constants"))) } if(type == "constant" && any(functions)) type <- "continuous" } switch(type, constant ={ ## set of constant graphics parameters defining a single symbol stuff <- list(type=type, parlist=parlist) ConstantValue <- as.data.frame(parlist, stringsAsFactors=FALSE) f <- function(x) ConstantValue }, discrete = { ## finite set of inputs mapped to symbols stuff <- list(type=type, inputs=inputs, parlist=parlist) f <- function(x) ApplyDiscreteSymbolMap(x, stuff) }, continuous = { got.shape <- "shape" %in% parnames got.size <- "size" %in% parnames got.cha <- any(c("pch", "chars") %in% parnames) ## interval of real line (etc) mapped to symbols or characters if(!got.cha) { ## mapped to symbols if(!got.shape) parlist$shape <- "circles" if(!got.size) stop("Parameter 'size' is missing") } rangetype <- if(is.null(range)) "numeric" else if(inherits(range, "POSIXt")) "datetime" else if(inherits(range, "Date")) "date" else if(is.numeric(range)) "numeric" else "unknown" stuff <- list(type=type, range=range, rangetype=rangetype, parlist=parlist) f <- function(x) ApplyContinuousSymbolMap(x, stuff) }) attr(f, "stuff") <- stuff class(f) <- c("symbolmap", class(f)) f } reptolength <- function(z, n) { rep.int(z, n)[1:n] } MapDiscrete <- function(f, x, i) { if(is.function(f)) f(x) else if(length(f) == 1) rep.int(f, length(x)) else f[i] } MapContinuous <- function(f, x) { if(is.function(f)) f(x) else rep.int(f, length(x)) } ApplyContinuousSymbolMap <- function(x, stuff) { with(stuff, { y <- as.data.frame(lapply(parlist, MapContinuous, x=x), stringsAsFactors=FALSE) return(y) }) } ApplyDiscreteSymbolMap <- function(x, stuff) { with(stuff, { ii <- match(x, inputs) if(anyNA(ii)) stop("Some values do not belong to the domain of the symbol map") y <- as.data.frame(lapply(parlist, MapDiscrete, x=x, i=ii), stringsAsFactors=FALSE) return(y) }) } symbolmap }) symbolmaptype <- function(x) { attr(x, "stuff")$type } symbolmapdomain <- function(x) { stuff <- attr(x, "stuff") d <- switch(stuff$type, constant = { integer(0) }, discrete = { stuff$inputs }, continuous = { stuff$range }) return(d) } symbolmapparnames <- function(x) { names(attr(x, "stuff")[["parlist"]]) } update.symbolmap <- function(object, ...) { y <- attr(object, "stuff") oldargs <- append(y[["parlist"]], y[c("inputs", "range")]) do.call(symbolmap, resolve.defaults(list(...), oldargs)) } print.symbolmap <- function(x, ...) { with(attr(x, "stuff"), { switch(type, constant = { if(length(parlist) == 0) { cat("Symbol map", "with no parameters", fill=TRUE) } else { cat("Symbol map", "with constant values", fill=TRUE) } }, discrete = { cat("Symbol map", "for discrete inputs:", fill=TRUE) print(inputs) }, continuous = { cat("Symbol map", "for", switch(rangetype, numeric="real numbers", date = "dates", datetime = "date/time values", unknown = "unrecognised data"), if(!is.null(range)) paste("in", prange(range)) else NULL, fill=TRUE) }) if(length(parlist) > 0) { for(i in seq_along(parlist)) { cat(paste0(names(parlist)[i], ": ")) pari <- parlist[[i]] if(!is.function(pari) && length(pari) == 1) cat(pari, fill=TRUE) else print(pari) } } return(invisible(NULL)) }) } ## Function which actually plots the symbols. ## Called by plot.ppp and plot.symbolmap ## Returns maximum size of symbols invoke.symbolmap <- local({ ## plot points, handling various arguments do.points <- function(x, y, ..., cex=size, size=NULL, col=cols, pch=chars, cols=NULL, chars=NULL, lwd=1, etch=FALSE, do.plot=TRUE) { if(do.plot) { if(length(cex) == 0) cex <- 1 if(length(col) == 0) col <- par("col") if(length(pch) == 0) pch <- 1 if(length(lwd) == 0) lwd <- 1 n <- length(x) if(length(cex) == 1) cex <- rep(cex, n) if(length(col) == 1) col <- rep(col, n) if(length(pch) == 1) pch <- rep(pch, 1) if(length(lwd) == 1) lwd <- rep(lwd, n) if(length(etch) == 1) etch <- rep(etch, n) ## infer which arguments are parallelised other <- append(list(...), list(cex=cex, pch=pch)) isvec <- (lengths(other) == n) other.fixed <- other[!isvec] other.vec <- other[isvec] ## if(any(i <- as.logical(etch))) { anti.col <- complementarycolour(col) anti.lwd <- if(is.numeric(etch)) etch else 2 * lwd do.call.matched(points.default, resolve.defaults(list(x=x[i], y=y[i]), other.fixed, lapply(other.vec, "[", i=i), list(col=anti.col[i], lwd=anti.lwd[i])), extrargs=c("col", "pch", "type", "bg", "cex", "lwd", "lty")) } do.call.matched(points.default, resolve.defaults(list(x=x, y=y), other, list(col=col, lwd=lwd)), extrargs=c("col", "pch", "type", "bg", "cex", "lwd", "lty")) } return(max(cex %orifnull% 1)) } ## plot symbols likewise known.shapes <- c("circles", "squares", "arrows", "crossticks") do.symbols <- function(x, y, ..., shape, size=cex, cex=NULL, fg=col, col=cols, cols=NULL, lwd=1, etch=FALSE, angleref=0, do.plot=TRUE) { if(do.plot) { if(is.null(size)) stop("parameter 'size' is required", call.=FALSE) ## zap tiny sizes tiny <- (size < (max(size)/1000)) size[tiny] <- 0 ## collect arguments n <- length(x) if(length(lwd) == 1) lwd <- rep(lwd, n) if(length(etch) == 1) etch <- rep(etch, n) if(length(fg) == 0) fg <- rep(par("col"), n) else if(length(fg) == 1) fg <- rep(fg, n) if(length(angleref) == 1) angleref <- rep(angleref, n) other <- resolve.defaults(list(...), list(add=TRUE, inches=FALSE)) ## infer which arguments are parallelised isvec <- (lengths(other) == n) other.fixed <- other[!isvec] other.vec <- other[isvec] ## if(any(as.logical(etch))) { anti.fg <- complementarycolour(fg) anti.lwd <- if(is.numeric(etch)) etch else 2 * lwd } ## plot if(any(i <- (shape == "circles") & as.logical(etch))) do.call.matched(symbols, c(list(x=x[i], y=y[i], circles=size[i]/2), other.fixed, lapply(other.vec, "[", i=i), list(lwd=anti.lwd[i], fg=anti.fg[i])), extrargs=c("lwd", "lty")) if(any(i <- (shape == "circles"))) do.call.matched(symbols, c(list(x=x[i], y=y[i], circles=size[i]/2), other.fixed, lapply(other.vec, "[", i=i), list(lwd=lwd[i], fg=fg[i])), extrargs=c("lwd", "lty")) if(any(i <- (shape == "squares") & as.logical(etch))) do.call.matched(symbols, c(list(x=x[i], y=y[i], squares=size[i]), other.fixed, lapply(other.vec, "[", i=i), list(lwd=anti.lwd[i], fg=anti.fg[i])), extrargs=c("lwd", "lty")) if(any(i <- (shape == "squares"))) do.call.matched(symbols, c(list(x=x[i], y=y[i], squares=size[i]), other.fixed, lapply(other.vec, "[", i=i), list(lwd=lwd[i], fg=fg[i])), extrargs=c("lwd", "lty")) if(any(i <- (shape == "arrows") & as.logical(etch))) do.call.matched(do.arrows, c(list(x=x[i], y=y[i], len=size[i]), other.fixed, lapply(other.vec, "[", i=i), list(lwd=anti.lwd[i], cols=anti.fg[i])), extrargs=c("cols", "col", "lwd", "lty")) if(any(i <- (shape == "arrows"))) do.call.matched(do.arrows, c(list(x=x[i], y=y[i], len=size[i]), other.fixed, lapply(other.vec, "[", i=i), list(lwd=lwd[i], cols=fg[i])), extrargs=c("cols", "col", "lwd", "lty")) if(any(i <- (shape == "crossticks") & as.logical(etch))) do.call.matched(do.crossticks, c(list(x=x[i], y=y[i], len=size[i], angleref=angleref[i]), other.fixed, lapply(other.vec, "[", i=i), list(lwd=anti.lwd[i], cols=anti.fg[i])), extrargs=c("cols", "col", "lwd", "lty")) if(any(i <- (shape == "crossticks"))) do.call.matched(do.crossticks, c(list(x=x[i], y=y[i], len=size[i], angleref=angleref[i]), other.fixed, lapply(other.vec, "[", i=i), list(lwd=lwd[i], cols=fg[i])), extrargs=c("cols", "col", "lwd", "lty")) if(any(nomatch <- is.na(match(shape, known.shapes)))) { unknown <- unique(shape[nomatch]) nun <- length(unknown) warning(paste("Unrecognised", ngettext(nun, "shape", "shapes"), paste0(commasep(sQuote(unknown)), ";"), "recognised values are", commasep(sQuote(known.shapes))), call.=FALSE) } } return(max(size)) } do.arrows <- function(x, y, len, direction=0, arrowtype=2, ..., headlength=len * 0.4, headangle=40, cols=col, col=par('fg'), lwd=1, lty=1) { #' vectorise all arguments df <- data.frame(x=x, y=y, len=len, direction=direction, arrowtype=arrowtype, headlength=headlength, headangle=headangle, cols=cols, lwd=lwd, lty=lty) with(df, { alpha <- direction * pi/180 dx <- len * cos(alpha)/2 dy <- len * sin(alpha)/2 x0 <- x - dx x1 <- x + dx y0 <- y - dy y1 <- y + dy segments(x0, y0, x1, y1, ..., col=cols, lty=lty, lwd=lwd) if(any(arrowtype != 0)) { halfangle <- (headangle/2) * pi/180 beta1 <- alpha + halfangle beta2 <- alpha - halfangle hx1 <- headlength * cos(beta1) hy1 <- headlength * sin(beta1) hx2 <- headlength * cos(beta2) hy2 <- headlength * sin(beta2) if(any(left <- (arrowtype %in% c(1,3)))) { segments(x0[left], y0[left], (x0 + hx1)[left], (y0 + hy1)[left], ..., col=cols[left], lwd=lwd[left], lty=lty[left]) segments(x0[left], y0[left], (x0 + hx2)[left], (y0 + hy2)[left], ..., col=cols[left], lwd=lwd[left], lty=lty[left]) } if(any(right <- (arrowtype %in% c(2,3)))) { segments(x1[right], y1[right], (x1 - hx1)[right], (y1 - hy1)[right], ..., col=cols[right], lwd=lwd[right], lty=lty[right]) segments(x1[right], y1[right], (x1 - hx2)[right], (y1 - hy2)[right], ..., col=cols[right], lwd=lwd[right], lty=lty[right]) } } }) return(invisible(NULL)) } do.crossticks <- function(x, y, len, angleref=0, arrowtype=0, ..., direction = angleref + 90) { do.arrows(x=x, y=y, len=len, direction=direction, arrowtype=arrowtype, ...) } sanitycheck <- function(df, forbidden, kind) { ## 'df' is the result of a symbol map ## (applies to numeric, factor, character) bad <- sapply(lapply(df, forbidden), any) if(any(bad)) { stop(paste("Symbol map produced", kind, "values for", ngettext(sum(bad), "parameter", "parameters"), commasep(sQuote(colnames(df)[bad]))), call.=FALSE) } return(NULL) } ## main function invoke.symbolmap <- function(map, values, x=NULL, y=NULL, ..., angleref=NULL, add=FALSE, do.plot=TRUE, started = add && do.plot) { if(!inherits(map, "symbolmap")) stop("Argument 'map' should be an object of class 'symbolmap'") if(hasxy <- (!is.null(x) || !is.null(y))) { xy <- xy.coords(x, y) x <- xy$x y <- xy$y } if(is.null(angleref)) angleref <- numeric(length(x)) ## zeroes, or numeric(0) ## function will return maximum size of symbols plotted. maxsize <- 0 if(do.plot && !add) plot(x, y, type="n", ...) ## map numerical/factor values to graphical parameters g <- map(values) parnames <- colnames(g) ## trap user coding errors etc sanitycheck(g, is.na, "NA") sanitycheck(g, is.nan, "NaN") sanitycheck(g, is.infinite, "infinite") ## if(do.plot) { ## add spatial coordinates xydf <- data.frame(x=x, y=y, angleref=angleref) if(nrow(xydf) == 0) return(invisible(maxsize)) g <- if(prod(dim(g)) == 0) xydf else do.call(data.frame, c(as.list(g), as.list(xydf), list(stringsAsFactors=FALSE))) } n <- nrow(g) ## figure out which function does the graphics job need.points <- any(c("pch", "chars") %in% parnames) need.symbols <- "shape" %in% parnames if(need.symbols && need.points) { worker <- with(g, ifelse(!is.na(shape), "symbols", "points")) } else if(need.symbols) { worker <- rep.int("symbols", n) } else { worker <- rep.int("points", n) } ## split data according to graphics function involved z <- split(g, factor(worker)) ## display using 'pch' zpoints <- z[["points"]] if(!is.null(zpoints) && nrow(zpoints) > 0) { ms <- do.call(do.points, resolve.defaults(as.list(zpoints), list(...), list(do.plot=do.plot))) ## value is max(cex) ## guess size of one character charsize <- if(started) max(par('cxy')) else if(hasxy) max(sidelengths(boundingbox(x,y))/40) else 1/40 maxsize <- max(maxsize, charsize * ms) } ## display using 'symbols' zsymbols <- z[["symbols"]] if(!is.null(zsymbols) && nrow(zsymbols) > 0) { ms <- do.call(do.symbols, resolve.defaults(as.list(zsymbols), list(...), list(do.plot=do.plot))) ## ms value is max physical size. maxsize <- max(maxsize, ms) } return(invisible(maxsize)) } invoke.symbolmap }) ## Display the symbol map itself (`legend' style) plot.symbolmap <- function(x, ..., main, xlim=NULL, ylim=NULL, vertical=FALSE, side=c("bottom", "left", "top", "right"), annotate=TRUE, labelmap=NULL, add=FALSE, nsymbols=NULL, warn=TRUE, colour.only=FALSE, representatives=NULL) { if(missing(main)) main <- short.deparse(substitute(x)) miss.side <- missing(side) if(is.numeric(side)) { check.1.integer(side) side <- c("bottom", "left", "top", "right")[side] } side <- match.arg(side) # this may be overwritten later if miss.side=TRUE if(colour.only) { ## extract only the colour map and plot it cmap <- as.colourmap(x) if(inherits(cmap, "colourmap")) { if(miss.side) side <- if(vertical) "right" else "bottom" if(!is.numeric(side)) side <- match(side, c("bottom", "left", "top", "right")) result <- plot.colourmap(cmap, ..., main=main, xlim=xlim, ylim=ylim, vertical=vertical, side=side, labelmap=labelmap, add=add) return(result) } } type <- symbolmaptype(x) map <- x stuff <- attr(map, "stuff") if(type == "constant" && length(stuff$parlist) == 0) return(invisible(NULL)) if(is.null(labelmap)) { labelmap <- function(x) x } else if(type == "continuous" && is.numeric(labelmap) && length(labelmap) == 1) { labscal <- labelmap labelmap <- function(x) { x * labscal } } else stopifnot(is.function(labelmap)) ## determine the 'example' input values and their graphical representations switch(type, constant = { vv <- NULL }, continuous = { ra <- stuff$range if(!is.null(representatives)) { vv <- representatives if(!all(ok <- inside.range(vv, ra))) { nbad <- sum(!ok) vv <- vv[ok] warning(paste(nbad, "out of", length(vv), ngettext(nbad, "value", "values"), "in the argument", sQuote("representatives"), ngettext(nbad, "was", "were"), "outside the range of the symbol map, and", ngettext(nbad, "was", "were"), "removed"), call.=FALSE) } } else { if(is.null(ra)) stop("Cannot plot symbolmap with an infinite range") vv <- if(is.null(nsymbols)) prettyinside(ra) else prettyinside(ra, n = nsymbols) if(is.numeric(vv)) vv <- signif(vv, 4) } }, discrete = { dd <- stuff$inputs if(!is.null(representatives)) { vv <- representatives if(!all(ok <- vv %in% dd)) { nbad <- sum(!ok) vv <- vv[ok] warning(paste(nbad, "out of", length(vv), ngettext(nbad, "value", "values"), "in the argument", sQuote("representatives"), ngettext(nbad, "was", "were"), "outside the domain of the symbol map, and", ngettext(nbad, "was", "were"), "removed"), call.=FALSE) } } else { vv <- if(is.null(nsymbols)) prettydiscrete(dd) else prettydiscrete(dd, n = nsymbols) } if(warn && (length(vv) < length(dd))) { warning(paste("Only", length(vv), "out of", length(dd), "symbols are shown in the symbol map"), call.=FALSE) } if(vertical) vv <- rev(vv) }) nn <- length(vv) ## gg <- map(vv) ll <- paste(labelmap(vv)) ## determine position of plot and symbols if(add) { ## x and y limits must respect existing plot space usr <- par('usr') if(is.null(xlim)) xlim <- usr[1:2] if(is.null(ylim)) ylim <- usr[3:4] } else { ## create new plot maxdiam <- invoke.symbolmap(map, vv, do.plot=FALSE, started=FALSE, ...) zz <- c(0, max(1, maxdiam)) if(is.null(xlim) && is.null(ylim)) { if(vertical) { xlim <- zz ylim <- length(vv) * zz } else { xlim <- length(vv) * zz ylim <- zz } } else if(is.null(ylim)) { ylim <- zz } else if(is.null(xlim)) { xlim <- zz } } ## .......... initialise plot ............................... if(!add) do.call.matched(plot.default, resolve.defaults(list(x=xlim, y=ylim, type="n", main=main, axes=FALSE, xlab="", ylab="", asp=1.0), list(...))) ## maximum symbol diameter maxdiam <- invoke.symbolmap(map, vv, do.plot=FALSE, started=TRUE, ...) ## .......... plot symbols .................... if(type == "constant") { xp <- mean(xlim) yp <- mean(ylim) } else if(vertical) { ## vertical arrangement xp <- rep(mean(xlim), nn) vskip <- 1.1 * max(maxdiam, 3 * max(strheight(labelmap(vv)))) if(diff(ylim) > nn * vskip) { yp <- (1:nn) * vskip yp <- yp - mean(yp) + mean(ylim) } else { z <- seq(ylim[1], ylim[2], length=nn+1) yp <- z[-1] - diff(z)/2 } } else { ## horizontal arrangement yp <- rep(mean(ylim), nn) hskip <- 1.1 * max(maxdiam, max(strwidth(labelmap(vv)))) if(diff(xlim) > nn * hskip) { xp <- (1:nn) * hskip xp <- xp - mean(xp) + mean(xlim) } else { z <- seq(xlim[1], xlim[2], length=nn+1) xp <- z[-1] - diff(z)/2 } } invoke.symbolmap(map, vv, xp, yp, ..., add=TRUE, angleref=if(vertical) 90 else 0) ## ................. draw annotation .................. dotargs <- list(...) axiscol <- dotargs$col nac <- length(axiscol) if(nac > 0 && (!is.colour(axiscol) || nac > 1)) { ## only a single colour is permitted for 'axis' dotargs$col <- NULL } if(annotate && length(ll) > 0) { if(vertical) { ## default axis position is to the right if(miss.side) side <- "right" sidecode <- match(side, c("bottom", "left", "top", "right")) if(!(sidecode %in% c(2,4))) warning(paste("side =", sQuote(side), "is not consistent with vertical orientation")) pos <- c(ylim[1], xlim[1], ylim[2], xlim[2])[sidecode] ## draw axis do.call.matched(graphics::axis, resolve.defaults(dotargs, list(side=sidecode, pos=pos, at=yp, labels=ll, tick=FALSE, las=1)), extrargs=graphicsPars("axis")) } else { ## default axis position is below if(miss.side) side <- "bottom" sidecode <- match(side, c("bottom", "left", "top", "right")) if(!(sidecode %in% c(1,3))) warning(paste("side =", sQuote(side), "is not consistent with horizontal orientation")) pos <- c(ylim[1], xlim[1], ylim[2], xlim[2])[sidecode] ## draw axis do.call.matched(graphics::axis, resolve.defaults(dotargs, list(side = sidecode, pos = pos, at = xp, labels=ll, tick=FALSE)), extrargs=graphicsPars("axis")) } } return(invisible(NULL)) } plan.legend.layout <- function(B, ..., side=c("bottom", "left", "top", "right"), sep=NULL, leg.size=NULL, sep.frac=0.05, size.frac=0.05, started=FALSE, map=NULL) { ## Determine size and position of a box containing legend or symbolmap ## attached to a plot in region 'B'. ## sep, leg.size are absolute distances; ## sep.frac, size.frac are fractions of the maximum sidelength of B. side <- match.arg(side) B <- as.rectangle(B) Bsize <- max(sidelengths(B)) if(is.null(leg.size)) { leg.size <- size.frac * Bsize } else { check.1.real(leg.size) stopifnot(leg.size > 0) } if(is.null(sep)) { sep <- sep.frac * Bsize } else { check.1.real(sep) stopifnot(sep > 0) } if(is.null(map) || !inherits(map, "symbolmap")) { vv <- NULL textlength <- 8 } else { vv <- with(attr(map, "stuff"), if(type == "discrete") inputs else prettyinside(range)) textlength <- max(nchar(paste(vv))) } if(started && !is.null(vv)) { textwidth <- max(strwidth(vv)) textheight <- max(strheight(vv)) } else { ## the plot has not been initialised: guess character size charsize <- diff(if(side %in% c("left", "right")) B$yrange else B$xrange)/40 textwidth <- charsize * textlength textheight <- charsize } switch(side, right={ ## symbols to right of image b <- owinInternalRect(B$xrange[2] + sep + c(0, leg.size), B$yrange) ## text to right of symbols tt <- owinInternalRect(b$xrange[2] + sep + c(0, textwidth), b$yrange) iside <- 4 }, left={ ## symbols to left of image b <- owinInternalRect(B$xrange[1] - sep - c(leg.size, 0), B$yrange) ## text to left of symbols tt <- owinInternalRect(b$xrange[1] - sep - c(textwidth, 0), b$yrange) iside <- 2 }, top={ ## symbols above image b <- owinInternalRect(B$xrange, B$yrange[2] + sep + c(0, leg.size)) ## text above symbols tt <- owinInternalRect(b$xrange, b$yrange[2] + 3* charsize + c(0, textheight)) iside <- 3 }, bottom={ ## symbols below image b <- owinInternalRect(B$xrange, B$yrange[1] - sep - c(leg.size, 0)) ## text below symbols tt <- owinInternalRect(b$xrange, b$yrange[1] - 3 * charsize - c(textheight, 0)) iside <- 1 }) A <- boundingbox(B, b, tt) return(list(A=A, B=B, b=b, tt=tt, iside=iside, side=side, size=leg.size, charsize=charsize, sep=sep)) } as.colourmap.symbolmap <- function(x, ..., warn=TRUE) { ## extract only the colour map and plot it parlist <- attr(x, "stuff")$parlist iscol <- sapply(parlist, inherits, what="colourmap") nc <- sum(iscol) if(nc == 0) { if(warn) warning("No colour map information was detected", call.=FALSE) return(NULL) } used <- which(iscol)[[1L]] cmap <- parlist[[used]] if(nc > 1 && warn && length(unique(parlist[iscol])) > 1) warning(paste("More than one colour map was detected;", "using the colour map for", sQuote(names(parlist)[used])), call.=FALSE) return(cmap) } summary.symbolmap <- function(object, ...) { st <- attr(object, "stuff") typ <- st[["type"]] dom <- switch(typ, constant = { integer(0) }, discrete = { st$inputs }, continuous = { st$range }) parlist <- st[["parlist"]] parnames <- names(parlist) iscolmap <- sapply(parlist, inherits, what="colourmap") isatom <- sapply(parlist, is.atomic) lenfs <- lengths(parlist) isconstant <- isatom & (lenfs == 1) if(any(iscolmap)) isconstant[iscolmap] <- (lengths(lapply(parlist[iscolmap], colouroutputs)) == 1) colournames <- c("col", "cols", "fg", "bg", "border", "fill") shapenames <- c("shape", "pch", "chars", "direction", "arrowtype", "headlength", "headangle", "etch") sizenames <- c("size", "cex", "headlength") physicalsizenames <- c("size", "headlength") iscolour <- iscolmap | (parnames %in% colournames) isshape <- parnames %in% shapenames issize <- parnames %in% sizenames isphysical <- parnames %in% physicalsizenames fixedcolour <- all(isconstant[iscolour]) fixedshape <- all(isconstant[isshape]) fixedsize <- all(isconstant[issize]) z <- list(type = typ, domain = dom, pars = parnames, colmaps = parnames[iscolmap], rangetype = if(typ == "continuous") st[["rangetype"]] else NULL, range = if(typ == "continuous") st[["range"]] else NULL, isconstant = isconstant, # vector iscolour = iscolour, # vector issize = issize, # vector isshape = isshape, # vector isphysical = isphysical, # vector fixedshape = fixedshape, # logical(1) fixedsize = fixedsize, # logical(1) fixedcolour = fixedcolour # logical(1) ) class(z) <- c("summary.symbolmap", class(z)) return(z) } print.summary.symbolmap <- function(x, ...) { with(x, { switch(type, constant = { if(length(pars) == 0) { cat("Symbol map", "with no parameters", fill=TRUE) } else { cat("Symbol map", "with constant values", fill=TRUE) } }, discrete = { cat("Symbol map", "for discrete inputs:", fill=TRUE) print(domain) }, continuous = { cat("Symbol map", "for", switch(rangetype, numeric="real numbers", date = "dates", datetime = "date/time values", unknown = "unrecognised data"), if(!is.null(range)) paste("in", prange(range)) else NULL, fill=TRUE) }) if(length(pars) > 0) { splat("Graphics parameters defined:") splat(paste("\t", sQuote(pars), "\t", paren(ifelse(isconstant, "constant", "variable")), "\t", ifelse(pars %in% colmaps, "(colour map)", ""), "\n")) if(all(isconstant)) { splat("All graphics parameters are constant") } else { att <- c("size", "shape", "colour") fux <- c(fixedsize, fixedshape, fixedcolour) attfux <- att[fux] attnon <- att[!fux] blurb <- "Symbols have" if(length(attfux)) blurb <- paste(blurb, "fixed", commasep(attfux, " and ")) if(length(attnon)) { if(length(attfux)) blurb <- paste0(blurb, ", but") blurb <- paste(blurb, "variable", commasep(attnon, " and ")) } splat(blurb) } } return(invisible(NULL)) }) } default.symbolmap <- function(x, ...) { UseMethod("default.symbolmap") } spatstat.geom/R/fardist.R0000644000176200001440000000331414611065351015026 0ustar liggesusers## ## fardist.R ## ## Farthest distance to boundary ## ## $Revision: 1.13 $ $Date: 2022/05/21 09:52:11 $ fardist <- function(X, ...) { UseMethod("fardist") } fardist.owin <- function(X, ..., squared=FALSE) { verifyclass(X, "owin") M <- as.mask(X, ...) V <- if(is.mask(X)) vertices(M) else vertices(X) nx <- dim(M)[2L] ny <- dim(M)[1L] x0 <- M$xcol[1L] y0 <- M$yrow[1L] xstep <- M$xstep ystep <- M$ystep if(squared) { z <- .C(SG_fardist2grid, nx = as.integer(nx), x0 = as.double(x0), xstep = as.double(xstep), ny = as.integer(ny), y0 = as.double(y0), ystep = as.double(ystep), np = as.integer(length(V$x)), xp = as.double(V$x), yp = as.double(V$y), dfar = as.double(numeric(nx * ny)), PACKAGE="spatstat.geom") } else { z <- .C(SG_fardistgrid, nx = as.integer(nx), x0 = as.double(x0), xstep = as.double(xstep), ny = as.integer(ny), y0 = as.double(y0), ystep = as.double(ystep), np = as.integer(length(V$x)), xp = as.double(V$x), yp = as.double(V$y), dfar = as.double(numeric(nx * ny)), PACKAGE="spatstat.geom") } out <- im(z$dfar, xcol=M$xcol, yrow=M$yrow, xrange=M$xrange, yrange=M$yrange, unitname=unitname(M)) if(!is.rectangle(X)) out <- out[X, drop=FALSE] return(out) } fardist.ppp <- function(X, ..., squared=FALSE) { verifyclass(X, "ppp") V <- vertices(Window(X)) D2 <- crossdist(X$x, X$y, V$x, V$y, squared=TRUE) D2max <- apply(D2, 1L, max) if(squared) return(D2max) else return(sqrt(D2max)) } spatstat.geom/R/hexagons.R0000644000176200001440000000531314611065352015210 0ustar liggesusers## hexagons.R ## $Revision: 1.6 $ $Date: 2017/02/07 07:35:32 $ hexgrid <- function(W, s, offset=c(0,0), origin=NULL, trim=TRUE) { W <- as.owin(W) check.1.real(s) stopifnot(s > 0) hstep <- 3 * s vstep <- sqrt(3) * s R <- grow.rectangle(as.rectangle(W), hstep) xr <- R$xrange yr <- R$yrange ## initial positions for 'odd' and 'even grids p0 <- as2vector(origin %orifnull% centroid.owin(R)) p0 <- p0 + as2vector(offset) q0 <- p0 + c(hstep, vstep)/2 ## 'even' points p0 <- c(startinrange(p0[1L], hstep, xr), startinrange(p0[2L], vstep, yr)) if(!anyNA(p0)) { xeven <- prolongseq(p0[1L], xr, step=hstep) yeven <- prolongseq(p0[2L], yr, step=vstep) xyeven <- expand.grid(x=xeven, y=yeven) } else xyeven <- list(x=numeric(0), y=numeric(0)) ## 'odd' points q0 <- c(startinrange(q0[1L], hstep, xr), startinrange(q0[2L], vstep, yr)) if(!anyNA(q0)) { xodd <- prolongseq(q0[1L], xr, step=hstep) yodd <- prolongseq(q0[2L], yr, step=vstep) xyodd <- expand.grid(x=xodd, y=yodd) } else xyodd <- list(x=numeric(0), y=numeric(0)) ## xy <- concatxy(xyeven, xyodd) XY <- as.ppp(xy, W=R) ## if(trim) return(XY[W]) ok <- inside.owin(XY, w=dilation.owin(W, s)) return(XY[ok]) } hextess <- function(W, s, offset=c(0,0), origin=NULL, trim=TRUE) { W <- as.owin(W) G <- hexgrid(W=W, s=s, offset=offset, origin=origin, trim=FALSE) if(trim && is.mask(W)) { ## Result is a pixel image tessellation ## Determine pixel resolution by extending 'W' to larger domain of 'G' rasta <- harmonise.im(as.im(1, W), as.owin(G))[[1L]] rasta <- as.mask(rasta) ## Tweak G to have mask window G$window <- rasta ## img <- nnmap(G, what="which") result <- tess(image=img) return(result) } ## Result is a polygonal tessellation Gxy <- as.matrix(as.data.frame(G)) n <- nrow(Gxy) ## Hexagon centred at origin hex0 <- disc(npoly=6, radius=s) ## Form hexagons hexes <- vector(mode="list", length=n) for(i in 1:n) hexes[[i]] <- shift(hex0, Gxy[i,]) ## Determine whether tiles intersect window wholly or partly suspect <- rep(TRUE, n) GW <- G[W] GinW <- inside.owin(G, w=W) suspect[GinW] <- (bdist.points(GW) <= s) ## Compute intersection of tiles with window trimmed <- hexes trimmed[suspect] <- trimmed.suspect <- lapply(trimmed[suspect], intersect.owin, B=W, fatal=FALSE) nonempty <- rep(TRUE, n) nonempty[suspect] <- !unlist(lapply(trimmed.suspect, is.empty)) if(trim) { ## return the tiles intersected with W result <- tess(tiles=trimmed[nonempty], window=W) } else { ## return the tiles that have nonempty intersection with W result <- tess(tiles=hexes[nonempty]) } return(result) } spatstat.geom/R/marks.R0000644000176200001440000002676014611065352014522 0ustar liggesusers# # marks.R # # $Revision: 1.47 $ $Date: 2020/03/23 07:18:53 $ # # stuff for handling marks # # marks <- function(x, ...) { UseMethod("marks") } marks.default <- function(x, ...) { NULL } # The 'dfok' switch is temporary # while we convert the code to accept data frames of marks marks.ppp <- function(x, ..., dfok=TRUE, drop=TRUE) { ma <- x$marks if((is.data.frame(ma) || is.matrix(ma))) { if(!dfok) stop("Sorry, not implemented when the marks are a data frame") if(drop && ncol(ma) == 1) ma <- ma[,1,drop=TRUE] } return(ma) } # ------------------------------------------------------------------ "marks<-" <- function(x, ..., value) { UseMethod("marks<-") } "marks<-.ppp" <- function(x, ..., dfok=TRUE, drop=TRUE, value) { np <- npoints(x) m <- value switch(markformat(m), none = { return(unmark(x)) }, vector = { # vector of marks if(length(m) == 1) m <- rep.int(m, np) else if(np == 0) m <- rep.int(m, 0) # ensures marked pattern obtained else if(length(m) != np) stop("number of points != number of marks") marx <- m }, dataframe = { if(!dfok) stop("Sorry, data frames of marks are not yet implemented") m <- as.data.frame(m) # data frame of marks if(ncol(m) == 0) { # no mark variables marx <- NULL } else { # marks to be attached if(nrow(m) == np) { marx <- m } else { # lengths do not match if(nrow(m) == 1 || np == 0) { # replicate data frame marx <- as.data.frame(lapply(as.list(m), function(x, k) { rep.int(x, k) }, k=np)) } else stop("number of rows of data frame != number of points") } # convert single-column data frame to vector? if(drop && ncol(marx) == 1) marx <- marx[,1,drop=TRUE] } }, hyperframe = stop("Hyperframes of marks are not supported in ppp objects; use ppx"), stop("Format of marks is not understood") ) # attach/overwrite marks Y <- ppp(x$x,x$y,window=x$window,marks=marx, check=FALSE, drop=drop) return(Y) } "%mark%" <- setmarks <- function(x,value) { marks(x) <- value return(x) } # ------------------------------------------------- markformat <- function(x) { UseMethod("markformat") } markformat.ppp <- function(x) { mf <- x$markformat if(is.null(mf)) mf <- markformat(marks(x)) return(mf) } markformat.default <- function(x) { if(is.null(x)) return("none") if(is.null(dim(x))) { if(is.vector(x) || is.factor(x) || is.atomic(x)) return("vector") if(inherits(x, "POSIXt") || inherits(x, "Date")) return("vector") } if(is.data.frame(x) || is.matrix(x)) return("dataframe") if(is.hyperframe(x)) return("hyperframe") if(inherits(x, c("solist", "anylist", "listof"))) return("list") stop("Mark format not understood") } # ------------------------------------------------------------------ "is.marked" <- function(X, ...) { UseMethod("is.marked") } "is.marked.ppp" <- function(X, na.action="warn", ...) { marx <- marks(X, ...) if(is.null(marx)) return(FALSE) if((length(marx) > 0) && anyNA(marx)) { gripe <- paste("some mark values are NA in the point pattern", short.deparse(substitute(X))) switch(na.action, warn = warning(gripe, call.=FALSE), fatal = stop(gripe, call.=FALSE), ignore = {} ) } return(TRUE) } "is.marked.default" <- function(...) { return(!is.null(marks(...))) } # ------------------------------------------------------------------ is.multitype <- function(X, ...) { UseMethod("is.multitype") } is.multitype.default <- function(X, ...) { m <- marks(X) if(is.null(m)) return(FALSE) if(!is.null(dim(m))) { # should have a single column if(dim(m)[2] != 1) return(FALSE) m <- m[,1,drop=TRUE] } return(is.factor(m)) } is.multitype.ppp <- function(X, na.action="warn", ...) { marx <- marks(X, dfok=TRUE) if(is.null(marx)) return(FALSE) if((is.data.frame(marx) || is.hyperframe(marx)) && ncol(marx) > 1) return(FALSE) if(!is.factor(marx)) return(FALSE) if((length(marx) > 0) && anyNA(marx)) switch(na.action, warn = { warning(paste("some mark values are NA in the point pattern", short.deparse(substitute(X)))) }, fatal = { return(FALSE) }, ignore = {} ) return(TRUE) } # ------------------------------------------------------------------ unmark <- function(X) { UseMethod("unmark") } unmark.ppp <- function(X) { X$marks <- NULL X$markformat <- "none" return(X) } unmark.splitppp <- function(X) { Y <- lapply(X, unmark.ppp) class(Y) <- c("splitppp", class(Y)) return(Y) } ##### utility functions for subsetting & combining marks ######### marksubset <- function(x, index, format=NULL) { if(is.null(format)) format <- markformat(x) switch(format, none={return(NULL)}, list=, vector={return(x[index])}, hyperframe=, dataframe={return(x[index,,drop=FALSE])}, stop("Internal error: unrecognised format of marks")) } "%msub%" <- marksubsetop <- function(x,i) { marksubset(x, i) } "%mrep%" <- markreplicateop <- function(x,n) { format <- markformat(x) switch(format, none={return(NULL)}, list=, vector={ return(rep.int(x,n))}, dataframe={ return(as.data.frame(lapply(x, rep, times=n))) }, hyperframe={ xcols <- as.list(x) repxcols <- lapply(xcols, rep, times=n) return(do.call(hyperframe, repxcols)) }, stop("Internal error: unrecognised format of marks")) } "%mapp%" <- markappendop <- function(x,y) { fx <- markformat(x) fy <- markformat(y) if(fx != fy) { ## vectors can be appended to single-column arrays xvec <- (fx == "vector") yvec <- (fy == "vector") xdf <- (fx %in% c("dataframe", "hyperframe")) && (ncol(x) == 1L) ydf <- (fy %in% c("dataframe", "hyperframe")) && (ncol(y) == 1L) if(xvec && ydf) { x <- as.data.frame(x) names(x) <- names(y) fx <- "dataframe" } else if(xdf && yvec) { y <- as.data.frame(y) names(y) <- names(x) fy <- "dataframe" } else stop("Attempted to concatenate marks that are not compatible") } switch(fx, none = { return(NULL) }, vector = { if(is.factor(x) || is.factor(y)) return(cat.factor(x,y)) return(c(x,y)) }, hyperframe=, dataframe = { return(rbind(x,y)) }, list = { z <- append(x,y) z <- as.solist(z, demote=TRUE) return(z) }, stop("Internal error: unrecognised format of marks")) } markappend <- function(...) { # combine marks from any number of patterns marxlist <- list(...) # check on compatibility of marks mkfmt <- sapply(marxlist,markformat) if(length(ufm <- unique(mkfmt))>1) stop(paste("Cannot append marks of different formats:", commasep(sQuote(ufm))), call.=FALSE) mkfmt <- mkfmt[1] # combine the marks switch(mkfmt, none = { return(NULL) }, vector = { marxlist <- lapply(marxlist, function(x){as.data.frame.vector(x,nm="v1")}) marx <- do.call(rbind, marxlist)[,1] return(marx) }, hyperframe =, dataframe = { # check compatibility of data frames # (this is redundant but gives more helpful message) nama <- lapply(marxlist, names) dims <- lengths(nama) if(length(unique(dims)) != 1) stop("Data frames of marks have different column dimensions.") samenames <- unlist(lapply(nama, function(x,y) { identical(x,y) }, y=nama[[1]])) if(!all(samenames)) stop("Data frames of marks have different names.\n") marx <- do.call(rbind, marxlist) return(marx) }, list = { marx <- do.call(c, marxlist) marx <- as.solist(marx, demote=TRUE) return(marx) }) stop("Unrecognised mark format") } markcbind <- function(...) { # cbind several columns of marks marxlist <- list(...) mkfmt <- unlist(lapply(marxlist, markformat)) if(any(vacuous <- (mkfmt == "none"))) { marxlist <- marxlist[!vacuous] mkfmt <- mkfmt[!vacuous] } if(any(isvec <- (mkfmt == "vector"))) { ## convert vectors to data frames with invented names for(i in which(isvec)) { mi <- as.data.frame(marxlist[i]) colnames(mi) <- paste0("V", i) marxlist[[i]] <- mi } mkfmt[isvec] <- "dataframe" } if(all(mkfmt == "dataframe")) { ## result is a data frame marx <- do.call(data.frame, marxlist) } else { ## result is a hyperframe if(!all(ishyp <- (mkfmt == "hyperframe"))) marxlist[!ishyp] <- lapply(marxlist[!ishyp], as.hyperframe) marx <- do.call(hyperframe, marxlist) } return(marx) } numeric.columns <- local({ ## extract only the columns of (passably) numeric data from a data frame process <- function(z, logi, other) { if(is.numeric(z)) return(z) if(logi && is.logical(z)) return(as.integer(z)) switch(other, na=rep.int(NA_real_, length(z)), discard=NULL, NULL) } numeric.columns <- function(M, logical=TRUE, others=c("discard", "na")) { others <- match.arg(others) M <- as.data.frame(M) if(ncol(M) == 1) colnames(M) <- NULL Mprocessed <- lapply(M, process, logi=logical, other=others) isnul <- unlist(lapply(Mprocessed, is.null)) if(all(isnul)) { #' all columns have been removed #' return a data frame with no columns return(as.data.frame(matrix(, nrow=nrow(M), ncol=0))) } Mout <- do.call(data.frame, Mprocessed[!isnul]) if(ncol(M) == 1 && ncol(Mout) == 1) colnames(Mout) <- NULL return(Mout) } numeric.columns }) coerce.marks.numeric <- function(X, warn=TRUE) { marx <- marks(X) if(is.null(dim(marx))) { if(is.factor(marx)) { if(warn) warning("Factor-valued marks were converted to integer codes", call.=FALSE) marx <- as.integer(marx) return(X %mark% marx) } } else { marx <- as.data.frame(marx) if(any(fax <- unlist(lapply(marx, is.factor)))) { if(warn) { nf <- sum(fax) whinge <- paste("Factor-valued mark", ngettext(nf, "variable", "variables"), commasep(sQuote(colnames(marx)[fax])), ngettext(nf, "was", "were"), "converted to integer codes") warning(whinge, call.=FALSE) } marx[fax] <- as.data.frame(lapply(marx[fax], as.integer)) return(X %mark% marx) } } return(X) } #' for 'print' methods markvaluetype <- function(x) { if(is.hyperframe(x)) return(unclass(x)$vclass) if(!is.null(dim(x))) x <- as.data.frame(x) if(is.data.frame(x)) return(sapply(x, markvaluetype)) if(inherits(x, c("POSIXt", "Date"))) return("date-time") if(is.factor(x)) return("factor") return(typeof(x)) } spatstat.geom/R/quadratcount.R0000644000176200001440000001623314611065352016111 0ustar liggesusers# # quadratcount.R # # $Revision: 1.67 $ $Date: 2023/08/15 13:21:39 $ # quadratcount <- function(X, ...) { UseMethod("quadratcount") } quadratcount.splitppp <- function(X, ...) { solapply(X, quadratcount, ...) } quadratcount.ppp <- function(X, nx=5, ny=nx, ..., xbreaks=NULL, ybreaks=NULL, tess=NULL) { verifyclass(X, "ppp") W <- X$window if(is.null(tess)) { ## rectangular boundaries if(!is.numeric(nx)) stop("nx should be numeric") ## start with rectangular tessellation tess <- quadrats(as.rectangle(W), nx=nx, ny=ny, xbreaks=xbreaks, ybreaks=ybreaks) ## fast code for counting points in rectangular grid Xcount <- rectquadrat.countEngine(X$x, X$y, tess$xgrid, tess$ygrid) ## if(W$type != "rectangle") { # intersections of rectangles with window including empty intersections tess <- quadrats(X, nx=nx, ny=ny, xbreaks=xbreaks, ybreaks=ybreaks, keepempty=TRUE) nonempty <- !tiles.empty(tess) if(!any(nonempty)) stop("All tiles are empty") if(!all(nonempty)) { ## reshape counts as 1-dim table corresponding to tiles Xcount <- as.integer(t(Xcount)) ## retain nonempty tiles tess <- tess[nonempty] ## retain corresponding counts Xcount <- Xcount[nonempty] ## attach tile names to counts Xcount <- array(Xcount, dimnames=list(tile=tilenames(tess))) class(Xcount) <- "table" } } } else { # user-supplied tessellation if(!inherits(tess, "tess")) { tess <- try(as.tess(tess), silent=TRUE) if(inherits(tess, "try-error")) stop("The argument tess should be a tessellation", call.=FALSE) } if(tess$type == "rect") { # fast code for counting points in rectangular grid Xcount <- rectquadrat.countEngine(X$x, X$y, tess$xgrid, tess$ygrid) } else { # quadrats are another type of tessellation Y <- cut(X, tess) if(anyNA(marks(Y))) warning("Tessellation does not contain all the points of X") Xcount <- table(tile=marks(Y)) } } attr(Xcount, "tess") <- tess class(Xcount) <- c("quadratcount", class(Xcount)) return(Xcount) } plot.quadratcount <- function(x, ..., add=FALSE, entries=as.integer(t(x)), dx=0, dy=0, show.tiles=TRUE, textargs = list()) { xname <- short.deparse(substitute(x)) tess <- attr(x, "tess") # add=FALSE, show.tiles=TRUE => plot tiles + numbers # add=FALSE, show.tiles=FALSE => plot window (add=FALSE) + numbers # add=TRUE, show.tiles=TRUE => plot tiles (add=TRUE) + numbers # add=TRUE, show.tiles=FALSE => plot numbers if(show.tiles || !add) { context <- if(show.tiles) tess else as.owin(tess) dont.complain.about(context) do.call(plot, resolve.defaults(list(quote(context), add=add), list(...), list(main=xname), .StripNull=TRUE)) } if(!is.null(entries)) { labels <- paste(as.vector(entries)) til <- tiles(tess) incircles <- lapply(til, incircle) x0 <- sapply(incircles, getElement, name="x") y0 <- sapply(incircles, getElement, name="y") ra <- sapply(incircles, getElement, name="r") xx <- x0 + dx *ra yy <- y0 + dy *ra dont.complain.about(xx, yy, labels) do.call.matched(text.default, resolve.defaults(list(x=quote(xx), y = quote(yy), labels=quote(labels)), textargs, list(...)), funargs=graphicsPars("text")) } return(invisible(NULL)) } rectquadrat.breaks <- function(xr, yr, nx=5, ny=nx, xbreaks=NULL, ybreaks=NULL) { if(is.null(xbreaks)) xbreaks <- seq(from=xr[1], to=xr[2], length.out=nx+1) else if(min(xbreaks) > xr[1] || max(xbreaks) < xr[2]) stop("xbreaks do not span the range of x coordinates in the window") if(is.null(ybreaks)) ybreaks <- seq(from=yr[1], to=yr[2], length.out=ny+1) else if(min(ybreaks) > yr[1] || max(ybreaks) < yr[2]) stop("ybreaks do not span the range of y coordinates in the window") return(list(xbreaks=xbreaks, ybreaks=ybreaks)) } rectquadrat.countEngine <- function(x, y, xbreaks, ybreaks, weights) { if(length(x) > 0) { # check validity of breaks if(!all(inside.range(range(x), range(xbreaks)))) stop("xbreaks do not span the actual range of x coordinates in data") if(!all(inside.range(range(y), range(ybreaks)))) stop("ybreaks do not span the actual range of y coordinates in data") } # WAS: # xg <- cut(x, breaks=xbreaks, include.lowest=TRUE) # yg <- cut(y, breaks=ybreaks, include.lowest=TRUE) xg <- fastFindInterval(x, xbreaks, labels=TRUE) yg <- fastFindInterval(y, ybreaks, labels=TRUE) if(missing(weights)) { sumz <- table(list(y=yg, x=xg)) } else { # was: # sumz <- tapply(weights, list(y=yg, x=xg), sum) # if(any(nbg <- is.na(sumz))) # sumz[nbg] <- 0 sumz <- tapplysum(weights, list(y=yg, x=xg), do.names=TRUE) } # reverse order of y sumz <- sumz[rev(seq_len(nrow(sumz))), ] sumz <- as.table(sumz) # attr(sumz, "xbreaks") <- xbreaks attr(sumz, "ybreaks") <- ybreaks return(sumz) } quadrats <- function(X, nx=5, ny=nx, xbreaks = NULL, ybreaks = NULL, keepempty=FALSE) { W <- as.owin(X) xr <- W$xrange yr <- W$yrange b <- rectquadrat.breaks(xr, yr, nx, ny, xbreaks, ybreaks) # rectangular tiles Z <- tess(xgrid=b$xbreaks, ygrid=b$ybreaks, unitname=unitname(W)) if(W$type != "rectangle") { # intersect rectangular tiles with window W if(!keepempty) { Z <- intersect.tess(Z, W) } else { til <- tiles(Z) for(i in seq_along(til)) til[[i]] <- intersect.owin(til[[i]], W) Z <- tess(tiles=til, window=W, keepempty=TRUE) } } return(Z) } as.tess.quadratcount <- function(X) { Y <- attr(X, "tess") m <- as.integer(t(X)) ## counts in order corresponding to tiles marks(Y) <- m return(Y) } as.owin.quadratcount <- function(W, ..., fatal=TRUE) { return(as.owin(as.tess(W), ..., fatal=fatal)) } domain.quadratcount <- Window.quadratcount <- function(X, ...) { as.owin(X) } intensity.quadratcount <- function(X, ..., image=FALSE) { Y <- as.tess(X) # marks are counts lambda <- marks(Y)[,1]/tile.areas(Y) if(image) { ## make an image tileid <- as.im(Y, ...) # values are tile index result <- eval.im(lambda[tileid]) } else { ## save as a table corresponding to X result <- X flip <- (length(dim(X)) == 2) if(flip) result <- t(result) result[] <- lambda if(flip) result <- t(result) class(result) <- "table" attr(result, "tess") <- NULL } return(result) } ## The shift method is undocumented. ## It is only needed in plot.listof / plot.solist / plot.layered shift.quadratcount <- function(X, ...) { attr(X, "tess") <- te <- shift(attr(X, "tess"), ...) attr(X, "lastshift") <- getlastshift(te) return(X) } spatstat.geom/R/util.R0000644000176200001440000004002114611065353014345 0ustar liggesusers# # util.R miscellaneous utilities # # $Revision: 1.268 $ $Date: 2023/09/04 03:45:14 $ # # common invocation of matrixsample rastersample <- function(X, Y) { stopifnot(is.im(X) || is.mask(X)) stopifnot(is.im(Y) || is.mask(Y)) phase <- c((Y$yrow[1] - X$yrow[1])/X$ystep, (Y$xcol[1] - X$xcol[1])/X$xstep) scale <- c(Y$ystep/X$ystep, Y$xstep/X$xstep) if(is.im(X)) { # resample an image if(!is.im(Y)) Y <- as.im(Y) Xtype <- X$type Xv <- X$v # handle factor-valued image as integer if(Xtype == "factor") Xv <- array(as.integer(Xv), dim=X$dim) # resample naval <- switch(Xtype, factor=, integer= NA_integer_, logical = as.logical(NA_integer_), real = NA_real_, complex = NA_complex_, character = NA_character_, NA) Y$v <- matrixsample(Xv, Y$dim, phase=phase, scale=scale, na.value=naval) # inherit pixel data type from X Y$type <- Xtype if(Xtype == "factor") { lev <- levels(X) Y$v <- factor(Y$v, labels=lev, levels=seq_along(lev)) dim(Y$v) <- Y$dim } } else { # resample a mask if(!is.mask(Y)) Y <- as.mask(Y) Y$m <- matrixsample(X$m, Y$dim, phase=phase, scale=scale, na.value=FALSE) } return(Y) } pointgrid <- function(W, ngrid) { W <- as.owin(W) masque <- as.mask(W, dimyx=ngrid) rxy <- rasterxy.mask(masque, drop=TRUE) xx <- rxy$x yy <- rxy$y return(ppp(xx, yy, W)) } onecolumn <- function(m) { switch(markformat(m), none=stop("No marks provided"), vector=m, dataframe=m[,1, drop=TRUE], NA) } checkbigmatrix <- function(n, m, fatal=FALSE, silent=FALSE) { nm <- as.numeric(n) * as.numeric(m) if(nm <= spatstat.options("maxmatrix")) return(TRUE) whinge <- paste("Attempted to create binary mask with", n, "*", m, "=", nm, "entries") if(fatal) stop(whinge, call.=FALSE) if(!silent) warning(whinge, call.=FALSE) return(FALSE) } ## ........... progress reports ..................... progressreport <- local({ Put <- function(name, value, state) { if(is.null(state)) { putSpatstatVariable(paste0("Spatstat.", name), value) } else { state[[name]] <- value } return(state) } Get <- function(name, state) { if(is.null(state)) { value <- getSpatstatVariable(paste0("Spatstat.", name)) } else { value <- state[[name]] } return(value) } Exists <- function(name, state) { if(is.null(state)) { answer <- existsSpatstatVariable(paste0("Spatstat.", name)) } else { answer <- name %in% names(state) } return(answer) } IterationsPerLine <- function(charsperline, n, every, tick, showtimeinline, showevery) { ## Calculate number of iterations that triggers a newline. ## A dot is printed every 'tick' iterations ## Iteration number is printed every 'every' iterations. ## ## Number of characters in each report of the iteration number chars.report <- max(1, ceiling(log10(n))) chars.punctu <- if(every == 1) nchar(', ') else 0 chars.report <- chars.report + chars.punctu if(showtimeinline) { ## If showtimeinline=TRUE, the time remaining is shown in brackets ## every 'showevery' iterations, where showevery \in {1, every, n}. ## If showtimeinline=FALSE, either the time remaining is never shown, ## or time remaining + estimated finish are displayed on a separate line. chars.time <- nchar(' [12:00:00 remaining] ') timesperreport <- if(showevery == 1) every else if(showevery == every) 1 else 0 chars.report <- chars.report + timesperreport * chars.time } ## Total number of characters in a complete block between iteration numbers chars.ticks <- floor((every-1)/tick) chars.block <- chars.report + chars.ticks ## Number of whole blocks per line nblocks <- max(1, floor(charsperline/chars.block)) ## Number of iterations per line nperline <- nblocks * every ## Adjust leftover <- charsperline - nblocks * chars.block if(leftover > 0) nperline <- nperline + min(leftover * tick, every - 1, showevery - 1) ## iteration number that triggers newline return(nperline) } progressreport <- function(i, n, every=min(100,max(1, ceiling(n/100))), tick=1, nperline=NULL, charsperline=getOption("width"), style=spatstat.options("progress"), showtime=NULL, state=NULL, formula=(time ~ i), savehistory=FALSE) { missevery <- missing(every) nperline.fixed <- !is.null(nperline) showtime.optional <- is.null(showtime) if(showtime.optional) showtime <- FALSE # initialise only if(i > n) { warning(paste("progressreport called with i =", i, "> n =", n)) return(invisible(NULL)) } if(style == "tk" && !requireNamespace("tcltk")) { warning("tcltk is unavailable; switching to style='txtbar'", call.=FALSE) style <- "txtbar" } if(is.null(state) && style != "tty") stop(paste("Argument 'state' is required when style =",sQuote(style)), call.=FALSE) ## determine model for extrapolation of time if(missing(formula)) formula <- NULL linear <- is.null(formula) if(!linear) { if(!inherits(formula, "formula")) stop(paste("Argument", sQuote("formula"), "should be a model formula"), call.=FALSE) savehistory <- TRUE } ## get current time if(savehistory || style == "tty") now <- proc.time() if(savehistory) { ahora <- as.numeric(now[3]) if(i == 1) { state <- Put("History", data.frame(i=i, time=ahora), state) } else { history <- Get("History", state) history <- rbind(history, data.frame(i=i, time=ahora)) state <- Put("History", history, state) } } ## display progress fallback <- FALSE switch(style, txtbar={ if(i == 1) { ## initialise text bar state <- Put("ProgressBar", txtProgressBar(1, n, 1, style=3), state) } else { ## get text bar pbar <- Get("ProgressBar", state) ## update setTxtProgressBar(pbar, i) if(i == n) { close(pbar) state <- Put("ProgressBar", NULL, state) } } }, tk={ requireNamespace("tcltk") if(i == 1) { ## initialise text bar state <- Put("ProgressBar", tcltk::tkProgressBar(title="progress", min=0, max=n, width=300), state) } else { ## get text bar pbar <- Get("ProgressBar", state) ## update tcltk::setTkProgressBar(pbar, i, label=paste0(round(100 * i/n), "%")) if(i == n) { close(pbar) state <- Put("ProgressBar", NULL, state) } } }, tty={ if(i == 1 || !Exists("ProgressData", state)) { ## Initialise stuff starttime <- now lastnewline <- 0 if(missevery && every > 1 && n > 10) every <- niceround(every) showevery <- if(showtime) every else n if(!nperline.fixed) nperline <- IterationsPerLine(charsperline, n, every, tick, showtime, showevery) } else { ## Extract information from previous state pd <- Get("ProgressData", state) if(is.null(pd)) stop(paste("progressreport called with i =", i, "before i = 1")) every <- pd$every tick <- pd$tick nperline <- pd$nperline lastnewline <- pd$lastnewline starttime <- pd$starttime showtime <- pd$showtime showevery <- pd$showevery showtime.optional <- pd$showtime.optional nperline.fixed <- pd$nperline.fixed if(i < n) { if(showtime || showtime.optional) { ## estimate time remaining elapsed <- now - starttime elapsed <- unname(elapsed[3]) if(linear) { rate <- elapsed/(i-1) remaining <- rate * (n-i) } else { fit <- try(lm(formula, data=history)) ok <- !inherits(fit, "try-error") && !anyNA(coef(fit)) if(ok) { pred <- suppressWarnings( predict(fit, newdata=data.frame(i=c(i, i+1, n))) ) ok <- all(diff(pred) >= 0) } if(ok) { ## predictions of model remaining <- pred[3] - pred[1] rate <- pred[2] - pred[1] } else { ## linear extrapolation fallback <- TRUE rate <- elapsed/(i-1) remaining <- rate * (n-i) } } if(!showtime) { ## Currently not showing the time remaining. ## Change this if: if(rate > 20) { ## .. more than 20 seconds until next iteration showtime <- TRUE showevery <- 1 } else if(remaining > 180) { ## ... more than 3 minutes remaining showtime <- TRUE showevery <- every aminute <- ceiling(60/rate) if(aminute < showevery) showevery <- min(niceround(aminute), showevery) } # update number of iterations per line if(showtime && !nperline.fixed) { showtimeinline <- (remaining < 600) nperline <- IterationsPerLine(charsperline, n, every, tick, showtimeinline, showevery) } } } } } ## determine whether newline is required offset <- if(lastnewline == 0 && every != 1) 6 else 0 do.newline <- ((i - lastnewline + offset) %% nperline == 0) ## Finally, print the report if(i == n) { cat(paste0("\n", n, ".\n")) } else if(every == 1 || i <= 3) { cat(paste0(i, ",", if(do.newline) "\n" else " ")) } else { if(i %% every == 0) cat(i) else if(i %% tick == 0) cat(".") if(do.newline) cat("\n") } if(showtime && i > 1 && i < n && (i %% showevery == 0)) { st <- paste(codetime(round(remaining)), paste0("remaining", if(fallback) "(linear)" else "")) if(longwait <- (remaining > 600)) { finishtime <- Sys.time() + remaining st <- paste0(st, ", estimate finish ", round(finishtime)) do.newline <- TRUE } st <- paren(st, "[") brk <- if(longwait) "\n" else " " cat(paste0(brk, st, brk)) } ## remember when the last newline occurred if(do.newline) lastnewline <- i ## save the current state state <- Put("ProgressData", list(every=every, tick=tick, nperline=nperline, lastnewline=lastnewline, starttime=starttime, showtime=showtime, showevery=showevery, nperline.fixed=nperline.fixed, showtime.optional=showtime.optional), state) flush.console() }, stop(paste("Unrecognised option for style:", dQuote(style))) ) return(invisible(state)) } progressreport }) ## .... special tweaks ......... multiply.only.finite.entries <- function(x, a) { # In ppm a potential value that is -Inf must remain -Inf # and a potential value that is 0 multiplied by NA remains 0 y <- x ok <- is.finite(x) & (x != 0) y[ok] <- a * x[ok] return(y) } ## print names and version numbers of libraries loaded sessionLibs <- local({ sessionLibs <- function() { a <- sessionInfo() d1 <- mangle(a$otherPkgs, "loaded") d2 <- mangle(a$loadedOnly, "imported") return(invisible(list(loaded=d1,imported=d2))) } mangle <- function(pkglist, type="loaded") { if(length(pkglist)) { b <- unlist(lapply(pkglist, getElement, name="Version")) b <- b[order(names(b))] g <- rbind(names(b), unname(b)) d <- apply(g, 2, paste, collapse=" ") } else d <- NULL if(length(d) > 0) { cat(paste0("Libraries ", type, ":\n")) for(di in d) cat(paste("\t", di, "\n")) } else cat(paste0("Libraries ", type, ": none\n")) return(invisible(d)) } sessionLibs }) # .................. prepareTitle <- function(main) { ## Count the number of lines in a main title ## Convert title to a form usable by plot.owin if(is.expression(main)) { nlines <- 1 } else { main <- paste(main) ## break at newline main <- unlist(strsplit(main, "\n")) nlines <- if(sum(nchar(main)) == 0) 0 else length(main) } return(list(main=main, nlines=nlines, blank=rep(' ', nlines))) } requireversion <- function(pkg, ver, fatal=TRUE) { pkgname <- deparse(substitute(pkg)) pkgname <- gsub("\"", "", pkgname) pkgname <- gsub("'", "", pkgname) dfile <- system.file("DESCRIPTION", package=pkgname) if(nchar(dfile) == 0) { ## package is not installed if(!fatal) return(FALSE) else stop(paste("Package", sQuote(pkgname), "is needed but is not installed"), call.=FALSE) } v <- read.dcf(file=dfile, fields="Version") ok <- (package_version(v) >= ver) if(!ok && fatal) stop(paste("Package", sQuote(pkgname), "is out of date: version >=", ver, "is needed"), call.=FALSE) return(if(ok) invisible(TRUE) else FALSE) } spatstatDiagnostic <- function(msg) { cat("-----------------------------\n") cat(paste(" >>> Spatstat Diagnostic: ", msg, "<<<\n")) cat("-----------------------------\n") invisible(NULL) } allElementsIdentical <- function(x, entry=NULL) { if(length(x) <= 1) return(TRUE) if(is.null(entry)) { x1 <- x[[1]] for(i in 2:length(x)) if(!identical(x[[i]], x1)) return(FALSE) } else { e1 <- x[[1]][[entry]] for(i in 2:length(x)) if(!identical(x[[i]][[entry]], e1)) return(FALSE) } return(TRUE) } resolve.stringsAsFactors <- function(stringsAsFactors=NULL) { if(is.null(stringsAsFactors) || is.na(stringsAsFactors)) { if(getRversion() < "4.1.0") default.stringsAsFactors() else FALSE } else isTRUE(stringsAsFactors) } spatstat.geom/R/breakptgeom.R0000644000176200001440000000464414611065351015701 0ustar liggesusers#' #' breakptgeom.R #' #' Functions for creating a 'breakpts' object #' that depend on geometry of window, etc. #' #' This code was excised from 'breakpts.R' #' #' handle.r.b.args Determine breakpoints for use in summary functions #' such as Kest, Gest, Fest which recognise #' arguments 'r' and 'breaks' and for which the #' defaults depend on window geometry. #' #' check.finespacing Verify that breakpoint spacing is sufficiently fine #' to ensure validity of discrete approximation to #' product integral etc. #' #' $Revision: 1.2 $ $Date: 2023/11/05 00:58:19 $ handle.r.b.args <- function(r=NULL, breaks=NULL, window, pixeps=NULL, rmaxdefault=NULL) { if(!is.null(r) && !is.null(breaks)) stop(paste("Do not specify both", sQuote("r"), "and", sQuote("breaks"))) if(!is.null(breaks)) { breaks <- as.breakpts(breaks) } else if(!is.null(r)) { breaks <- breakpts.from.r(r) } else { #' determine rmax #' ignore infinite or NA values of rmaxdefault if(!isTRUE(is.finite(rmaxdefault))) rmaxdefault <- NULL rmax <- rmaxdefault %orifnull% diameter(Frame(window)) #' determine spacing if(is.null(pixeps)) { pixeps <- if(is.mask(window)) min(window$xstep, window$ystep) else rmax/128 } rstep <- pixeps/4 breaks <- make.even.breaks(rmax, bstep=rstep) } return(breaks) } check.finespacing <- function(r, eps=NULL, win=NULL, rmaxdefault = max(r), context="", action=c("fatal", "warn", "silent"), rname) { if(missing(rname)) rname <- short.deparse(substitute(r)) action <- match.arg(action) if(is.null(eps)) { b <- handle.r.b.args(window=win, rmaxdefault=rmaxdefault) eps <- b$step } dr <- max(diff(r)) if(dr > eps * 1.01) { whinge <- paste(context, "the successive", rname, "values must be finely spaced:", "given spacing =", paste0(signif(dr, 5), ";"), "required spacing <= ", signif(eps, 3)) switch(action, fatal = stop(whinge, call.=FALSE), warn = warning(whinge, call.=FALSE), silent = {}) return(FALSE) } return(TRUE) } spatstat.geom/R/deldir.R0000644000176200001440000002504414712302612014635 0ustar liggesusers#' #' deldir.R #' #' Interface to deldir package #' #' $Revision: 1.40 $ $Date: 2022/05/21 09:52:11 $ #' #' .............................................. #' Internal options #' deldir suggests spatstat (!!!) #' so we must save options here, not in spatstat.options .spst.triEnv <- new.env() assign("use.trigraf", TRUE, envir=.spst.triEnv) assign("use.trigrafS", TRUE, envir=.spst.triEnv) assign("debug.delaunay", FALSE, envir=.spst.triEnv) #' for testing purposes only spatstat.deldir.setopt <- function(use.trigrafS=TRUE, use.trigraf=TRUE, debug.delaunay=FALSE) { assign("use.trigrafS", use.trigrafS, envir=.spst.triEnv) assign("use.trigraf", use.trigraf, envir=.spst.triEnv) assign("debug.delaunay", debug.delaunay, envir=.spst.triEnv) return(invisible(NULL)) } #'.............................................. dirichlet <- local({ dirichlet <- function(X) { stopifnot(is.ppp(X)) X <- unique(X, rule="deldir", warn=TRUE) nX <- npoints(X) w <- X$window if(nX == 0) return(NULL) if(nX == 1) return(as.tess(w)) dd <- safedeldir(X) if(is.null(dd)) return(NULL) tt <- deldir::tile.list(dd) pp <- lapply(tt, df2poly) if(length(pp) == npoints(X)) names(pp) <- seq_len(npoints(X)) dir <- tess(tiles=pp, window=as.rectangle(w)) if(w$type != "rectangle") dir <- intersect.tess(dir, w, keepempty=TRUE) return(dir) } df2poly <- function(z) { owin(poly=z[c("x","y")]) } dirichlet }) delaunay <- function(X) { stopifnot(is.ppp(X)) X <- unique(X, rule="deldir", warn=TRUE) nX <- npoints(X) if(nX < 3) return(NULL) w <- X$window dd <- safedeldir(X) if(is.null(dd)) return(NULL) a <- dd$delsgs[,5L] b <- dd$delsgs[,6L] use.trigraf <- get("use.trigraf", envir=.spst.triEnv) use.trigrafS <- get("use.trigrafS", envir=.spst.triEnv) debug.delaunay <- get("debug.delaunay", envir=.spst.triEnv) if(use.trigrafS) { # first ensure a[] < b[] swap <- (a > b) if(any(swap)) { oldb <- b b[swap] <- a[swap] a[swap] <- oldb[swap] } # next ensure a is sorted o <- order(a, b) a <- a[o] b <- b[o] # nv <- nX ne <- length(a) ntmax <- ne z <- .C(SG_trigrafS, nv = as.integer(nv), ne = as.integer(ne), ie = as.integer(a), je = as.integer(b), ntmax = as.integer(ntmax), nt = as.integer(integer(1L)), it = as.integer(integer(ne)), jt = as.integer(integer(ne)), kt = as.integer(integer(ne)), status = as.integer(integer(1L)), PACKAGE="spatstat.geom") if(z$status != 0) stop("Internal error: overflow in trigrafS") tlist <- with(z, cbind(it, jt, kt)[1:nt, ]) } else if(use.trigraf) { nv <- nX ne <- length(a) ntmax <- ne z <- .C(SG_trigraf, nv = as.integer(nv), ne = as.integer(ne), ie = as.integer(a), je = as.integer(b), ntmax = as.integer(ntmax), nt = as.integer(integer(1L)), it = as.integer(integer(ntmax)), jt = as.integer(integer(ntmax)), kt = as.integer(integer(ntmax)), status = as.integer(integer(1L)), PACKAGE="spatstat.geom") if(z$status != 0) stop("Internal error: overflow in trigraf") tlist <- with(z, cbind(it, jt, kt)[1:nt, ]) } else { tlist <- matrix(integer(0), 0, 3) for(i in seq_len(nX)) { # find all Delaunay neighbours of i jj <- c(b[a==i], a[b==i]) jj <- sortunique(jj) # select those with a higher index than i jj <- jj[jj > i] # find pairs of neighbours which are Delaunay neighbours # (thus, triangles where the first numbered vertex is i) if(length(jj) > 0) for(j in jj) { kk <- c(b[a == j], a[b == j]) kk <- kk[(kk %in% jj) & (kk > j)] if(length(kk) > 0) for(k in kk) # add (i,j,k) to list of triangles (i < j < k) tlist <- rbind(tlist, c(i, j, k)) } } } # At this point, `tlist' contains all triangles formed by the Delaunay edges, # with vertices given in ascending order i < j < k in the 3 columns of tlist. # Some of these triangles may not belong to the Delaunay triangulation. # They will be weeded out later. # Assemble coordinates of triangles x <- X$x y <- X$y xtri <- matrix(x[tlist], nrow(tlist), 3L) ytri <- matrix(y[tlist], nrow(tlist), 3L) # ensure triangle vertices are in anticlockwise order ztri <- ytri - min(y) dx <- cbind(xtri[,2L]-xtri[,1L], xtri[,3L]-xtri[,2L], xtri[,1L]-xtri[,3L]) zm <- cbind(ztri[,1L]+ztri[,2L], ztri[,2L]+ztri[,3L], ztri[,3L]+ztri[,1L]) negareas <- apply(dx * zm, 1L, sum) clockwise <- (negareas > 0) # if(any(clockwise)) { xc <- xtri[clockwise, , drop=FALSE] yc <- ytri[clockwise, , drop=FALSE] tc <- tlist[clockwise, , drop=FALSE] xtri[clockwise,] <- xc[,c(1L,3L,2L)] ytri[clockwise,] <- yc[,c(1L,3L,2L)] tlist[clockwise,] <- tc[, c(1L,3L,2L)] } # At this point, triangle vertices are listed in anticlockwise order. # The same directed edge (i, j) cannot appear twice. # To weed out invalid triangles, check for such duplication triedges <- rbind(tlist[, c(1L,2L)], tlist[, c(2L,3L)], tlist[, c(3L,1L)]) if(any(bad <- duplicated(triedges))) { badedges <- unique(triedges[bad, , drop=FALSE]) ntri <- nrow(tlist) triid <- rep.int(seq_len(ntri), 3) illegal <- rep.int(FALSE, ntri) for(j in seq_len(nrow(badedges))) { from <- badedges[j, 1L] to <- badedges[j, 2L] if(debug.delaunay) cat(paste("Suspect edge from vertex", from, "to vertex", to, "\n")) # find all triangles sharing this edge in this orientation sustri <- triid[(triedges[,1L] == from) & (triedges[,2L] == to)] if(debug.delaunay) cat(paste("\tInvestigating triangles", commasep(sustri), "\n")) # list all vertices associated with the suspect triangles susvert <- sortunique(as.vector(tlist[sustri, ])) if(debug.delaunay) cat(paste("\tInvestigating vertices", commasep(susvert), "\n")) xsusvert <- x[susvert] ysusvert <- y[susvert] # take each triangle in turn and check whether it contains a data point for(k in sustri) { if(!illegal[k] && any(inside.triangle(xsusvert, ysusvert, xtri[k,], ytri[k,]))) { if(debug.delaunay) cat(paste("Triangle", k, "is illegal\n")) illegal[k] <- TRUE } } } if(!any(illegal)) { if(debug.delaunay) cat("No illegal triangles found\n") } else { if(debug.delaunay) cat(paste("Removing", sum(illegal), "triangles\n")) tlist <- tlist[!illegal, , drop=FALSE] xtri <- xtri[!illegal, , drop=FALSE] ytri <- ytri[!illegal, , drop=FALSE] } } # make tile list tiles <- list() for(m in seq_len(nrow(tlist))) { p <- list(x=xtri[m,], y=ytri[m,]) tiles[[m]] <- owin(poly=p, check=FALSE) } wc <- convexhull.xy(x, y) del <- tess(tiles=tiles, window=wc) if(w$type != "rectangle") del <- intersect.tess(del, w, keepempty=TRUE) return(del) } delaunayDistance <- function(X) { stopifnot(is.ppp(X)) nX <- npoints(X) w <- as.owin(X) ok <- !duplicated(X, rule="deldir") Y <- X[ok] nY <- npoints(Y) if(nY < 3) return(matrix(Inf, nX, nX)) dd <- deldir(Y$x, Y$y, rw=c(w$xrange,w$yrange)) if(is.null(dd)) return(NULL) joins <- as.matrix(dd$delsgs[,5:6]) joins <- rbind(joins, joins[,2:1]) d <- matrix(-1L, nY, nY) diag(d) <- 0 d[joins] <- 1 adj <- matrix(FALSE, nY, nY) diag(adj) <- TRUE adj[joins] <- TRUE z <- .C(SG_Idist2dpath, nv = as.integer(nY), d = as.integer(d), adj = as.integer(adj), dpath = as.integer(integer(nY * nY)), tol = as.integer(0), niter = as.integer(integer(1L)), status = as.integer(integer(1L)), PACKAGE="spatstat.geom") if (z$status == -1L) warning(paste("graph connectivity algorithm did not converge after", z$niter, "iterations", "on", nY, "vertices and", sum(adj) - nY, "edges")) dpathY <- matrix(z$dpath, nY, nY) if(all(ok)) { dpathX <- dpathY } else { dpathX <- matrix(NA_integer_, nX, nX) dpathX[ok, ok] <- dpathY } return(dpathX) } safedeldir <- function(X) { rw <- with(X$window, c(xrange,yrange)) dd <- try(deldir(X$x, X$y, rw=rw)) if(!inherits(dd, "try-error") && inherits(dd, "deldir")) return(dd) warning("deldir failed; re-trying with slight perturbation of coordinates.", call.=FALSE) Y <- rjitter(X, mean(nndist(X))/100) dd <- try(deldir(Y$x, Y$y, rw=rw)) if(!inherits(dd, "try-error") && inherits(dd, "deldir")) return(dd) warning("deldir failed even after perturbation of coordinates.", call.=FALSE) return(NULL) } dirichletVertices <- function(X) { DT <- tiles(dirichlet(X)) xy <- do.call(concatxy, lapply(DT, vertices)) Y <- unique(ppp(xy$x, xy$y, window=Window(X), check=FALSE)) b <- bdist.points(Y) thresh <- diameter(Frame(X))/1000 Y <- Y[b > thresh] return(Y) } dirichletAreas <- function(X) { stopifnot(is.ppp(X)) X <- unmark(X) win <- Window(X) dup <- duplicated(X, rule="deldir") if((anydup <- any(dup))) { oldX <- X X <- X[!dup] } switch(win$type, rectangle = { rw <- c(win$xrange, win$yrange) dd <- deldir(X$x, X$y, rw=rw) w <- dd$summary[, 'dir.area'] }, polygonal = { w <- tile.areas(dirichlet(X)) }, mask = { #' Nearest data point to each pixel: tileid <- exactdt(X)$i #' Restrict to window (result is a vector - OK) tileid <- tileid[win$m] #' Count pixels in each tile id <- factor(tileid, levels=seq_len(X$n)) counts <- table(id) #' Convert to digital area pixelarea <- win$xstep * win$ystep w <- pixelarea * as.numeric(counts) }) if(!anydup) return(w) oldw <- numeric(npoints(oldX)) oldw[!dup] <- w return(oldw) } dirichletEdges <- function(X, clip=TRUE) { stopifnot(is.ppp(X)) X <- unique(X, rule="deldir") nX <- npoints(X) W <- Window(X) if(nX < 2) return(edges(W)) dd <- safedeldir(X) if(is.null(dd)) return(edges(W)) Z <- as.psp(dd$dirsgs[,1:4], window=Frame(W), check=FALSE) if(clip && !is.rectangle(W)) Z <- Z[W, fragments=TRUE] return(Z) } spatstat.geom/R/distancemetrics.R0000644000176200001440000000471614611065351016562 0ustar liggesusers#' #' distancemetrics.R #' #' Metrics on the spatial domain #' #' $Revision: 1.12 $ $Date: 2022/02/12 06:11:18 $ #' #' An object of class 'metric' is essentially a named list of functions #' where the names specify the tasks. #' #' An object of class 'metricfun' is a function that creates a metric #' #' See 'convexdist.R' for an example. ## .............. metric ................................ print.metric <- function(x, ...) { x$print() } summary.metric <- function(object, ...) { print(object, ...) splat("\nSupported operations:") splat(commasep(sQuote(names(object))), indent=5) invisible(NULL) } invoke.metric <- function(m, task, ..., evaluate=TRUE) { verifyclass(m, "metric") check.1.string(task) j <- match(task, names(m)) f <- if(is.na(j)) NULL else m[[j]] if(!evaluate) return(f) if(is.null(f)) stop(paste("This metric does not support", sQuote(task)), call.=FALSE) f(...) } ## .............. metricfun ............................. #' An object of class 'metricfun' is a function that creates a metric print.metricfun <- function(x, ...) { anames <- names(formals(x)) splat(paste0("function", paren(paste(anames,collapse=", ")))) if(!is.null(ex <- attr(x, "explain"))) splat(ex) return(invisible(NULL)) } ## ......... Utilities to trap user errors ........................ ## Utility for existing functions which do not support non-Euclidean metric) warn.no.metric.support <- function(caller, ..., metric) { if(!missing(metric)) warning(paste("Argument 'metric' is not implemented for", paste0(sQuote(caller), " and was ignored")), call.=FALSE) invisible(NULL) } ## Utility for use in metric counterparts of standard functions, ## when some arguments of standard function are unsupported by metric function ## (Issues a message only if the arguments have non-default values) warn.unsupported.args <- function(unsup, ...) { given <- list(...) if(any(names(unsup) %in% names(given))) { values <- resolve.defaults(given, unsup)[names(unsup)] changed <- !mapply(identical, x=unsup, y=values) if(any(changed)) { n <- sum(changed) warning(paste(ngettext(n, "Argument", "Arguments"), commasep(sQuote(names(unsup)[changed])), ngettext(n, "is", "are"), "not supported by this metric, and", ngettext(n, "was", "were"), "ignored"), call.=FALSE) } } invisible(NULL) } spatstat.geom/R/clip.psp.R0000644000176200001440000001762214611065351015131 0ustar liggesusers# # clip.psp.R # # $Revision: 1.25 $ $Date: 2022/05/21 09:52:11 $ # # ######################################################## # clipping operation (for subset) ######################################################## clip.psp <- function(x, window, check=TRUE, fragments=TRUE) { verifyclass(x, "psp") verifyclass(window, "owin") if(is.vanilla(unitname(window))) unitname(window) <- unitname(x) if(check && !is.subset.owin(window, x$window)) warning("The clipping window is not a subset of the window containing the line segment pattern x") if(x$n == 0) { emptypattern <- psp(numeric(0), numeric(0), numeric(0), numeric(0), window=window, marks=x$marks) return(emptypattern) } switch(window$type, rectangle={ result <- cliprect.psp(x, window, fragments=fragments) }, polygonal={ result <- clippoly.psp(x, window, fragments=fragments) }, mask={ result <- clippoly.psp(x, as.polygonal(window), fragments=fragments) result$window <- window }) return(result) } ##### # # clipping to a rectangle # cliprect.psp <- local({ cliprect.psp <- function(x, window, fragments=TRUE) { verifyclass(x, "psp") verifyclass(window, "owin") ends <- x$ends marx <- marks(x, dfok=TRUE) #' find segments which are entirely inside the window #' (by convexity) in0 <- inside.owin(ends$x0, ends$y0, window) in1 <- inside.owin(ends$x1, ends$y1, window) ok <- in0 & in1 #' if all segments are inside, return them if(all(ok)) return(as.psp(ends, window=window, marks=marx, check=FALSE)) #' otherwise, store those segments which are inside the window ends.inside <- ends[ok, , drop=FALSE] marks.inside <- marx %msub% ok x.inside <- as.psp(ends.inside, window=window, marks=marks.inside, check=FALSE) if(!fragments) return(x.inside) #' now consider the rest ends <- ends[!ok, , drop=FALSE] in0 <- in0[!ok] in1 <- in1[!ok] marx <- marx %msub% (!ok) #' first clip segments to the range x \in [xmin, xmax] #' use parametric coordinates tx <- cbind(ifelse0NA(between(ends$x0, window$xrange)), ifelse1NA(between(ends$x1, window$xrange)), tvalue(ends$x0, ends$x1, window$xrange[1L]), tvalue(ends$x0, ends$x1, window$xrange[2L])) #' discard segments which do not lie in the x range nx <- apply(!is.na(tx), 1L, sum) ok <- (nx >= 2) if(!any(ok)) return(x.inside) ends <- ends[ok, , drop=FALSE] tx <- tx[ok, , drop=FALSE] in0 <- in0[ok] in1 <- in1[ok] marx <- marx %msub% ok #' Clip the segments to the x range tmin <- apply(tx, 1L, min, na.rm=TRUE) tmax <- apply(tx, 1L, max, na.rm=TRUE) dx <- ends$x1 - ends$x0 dy <- ends$y1 - ends$y0 ends.xclipped <- data.frame(x0=ends$x0 + tmin * dx, y0=ends$y0 + tmin * dy, x1=ends$x0 + tmax * dx, y1=ends$y0 + tmax * dy) #' Now clip the segments to the range y \in [ymin, ymax] ends <- ends.xclipped in0 <- inside.owin(ends$x0, ends$y0, window) in1 <- inside.owin(ends$x1, ends$y1, window) ty <- cbind(ifelse0NA(in0), ifelse1NA(in1), tvalue(ends$y0, ends$y1, window$yrange[1L]), tvalue(ends$y0, ends$y1, window$yrange[2L])) #' discard segments which do not lie in the y range ny <- apply(!is.na(ty), 1L, sum) ok <- (ny >= 2) if(!any(ok)) return(x.inside) ends <- ends[ok, , drop=FALSE] ty <- ty[ok, , drop=FALSE] in0 <- in0[ok] in1 <- in1[ok] marx <- marx %msub% ok #' Clip the segments to the y range tmin <- apply(ty, 1L, min, na.rm=TRUE) tmax <- apply(ty, 1L, max, na.rm=TRUE) dx <- ends$x1 - ends$x0 dy <- ends$y1 - ends$y0 ends.clipped <- data.frame(x0=ends$x0 + tmin * dx, y0=ends$y0 + tmin * dy, x1=ends$x0 + tmax * dx, y1=ends$y0 + tmax * dy) marks.clipped <- marx #' OK - segments clipped #' Put them together with the unclipped ones ends.all <- rbind(ends.inside, ends.clipped) marks.all <- marks.inside %mapp% marks.clipped as.psp(ends.all, window=window, marks=marks.all, check=FALSE) } small <- function(x) { abs(x) <= .Machine$double.eps } tvalue <- function(z0, z1, zt) { y1 <- z1 - z0 yt <- zt - z0 tval <- ifelseAX(small(y1), 0.5, yt/y1) betwee <- (yt * (zt - z1)) <= 0 result <- ifelseXB(betwee, tval, NA) return(result) } between <- function(x, r) { ((x-r[1L]) * (x-r[2L])) <= 0 } cliprect.psp }) ############################ # # clipping to a polygonal window # clippoly.psp <- function(s, window, fragments=TRUE) { verifyclass(s, "psp") verifyclass(window, "owin") stopifnot(window$type == "polygonal") marx <- marks(s) has.marks <- !is.null(marx) eps <- .Machine$double.eps # find the intersection points between segments and window edges ns <- s$n es <- s$ends x0s <- es$x0 y0s <- es$y0 x1s <- es$x1 y1s <- es$y1 dxs <- x1s - x0s dys <- y1s - y0s bdry <- edges(window) nw <- bdry$n ew <- bdry$ends x0w <- ew$x0 y0w <- ew$y0 dxw <- ew$x1 - ew$x0 dyw <- ew$y1 - ew$y0 out <- .C(SG_xysegint, na=as.integer(ns), x0a=as.double(x0s), y0a=as.double(y0s), dxa=as.double(dxs), dya=as.double(dys), nb=as.integer(nw), x0b=as.double(x0w), y0b=as.double(y0w), dxb=as.double(dxw), dyb=as.double(dyw), eps=as.double(eps), xx=as.double(numeric(ns * nw)), yy=as.double(numeric(ns * nw)), ta=as.double(numeric(ns * nw)), tb=as.double(numeric(ns * nw)), ok=as.integer(integer(ns * nw)), PACKAGE="spatstat.geom") hitting <- (matrix(out$ok, ns, nw) != 0) ts <- matrix(out$ta, ns, nw) anyhit <- matrowany(hitting) if(!fragments) { #' retain only segments that avoid the boundary entirely leftin <- inside.owin(es$x0, es$y0, window) rightin <- inside.owin(es$x1, es$y1, window) ok <- !anyhit & leftin & rightin return(as.psp(es[ok,,drop=FALSE], window=window, marks=marx %msub% ok, check=FALSE)) } # form all the chopped segments (whether in or out) #' initially empty chopx0 <- chopy0 <- chopx1 <- chopy1 <- numeric(0) chopmarks <- marx %msub% integer(0) for(seg in seq_len(ns)) { #' coordinates of segment number 'seg' segx0 <- x0s[seg] segy0 <- y0s[seg] segx1 <- x1s[seg] segy1 <- y1s[seg] if(has.marks) segmarks <- marx %msub% seg if(!anyhit[seg]) { #' no intersection with boundary - add single segment chopx0 <- c(chopx0, segx0) chopy0 <- c(chopy0, segy0) chopx1 <- c(chopx1, segx1) chopy1 <- c(chopy1, segy1) if(has.marks) chopmarks <- chopmarks %mapp% segmarks } else { #' crosses boundary - add several pieces tvals <- ts[seg,] tvals <- sort(tvals[hitting[seg,]]) dx <- segx1 - segx0 dy <- segy1 - segy0 chopx0 <- c(chopx0, segx0 + c(0,tvals) * dx) chopy0 <- c(chopy0, segy0 + c(0,tvals) * dy) chopx1 <- c(chopx1, segx0 + c(tvals,1) * dx) chopy1 <- c(chopy1, segy0 + c(tvals,1) * dy) if(has.marks) { npieces <- length(tvals) + 1L chopmarks <- chopmarks %mapp% (segmarks %mrep% npieces) } } } chopped <- psp(chopx0, chopy0, chopx1, chopy1, window=boundingbox(Window(s), window), marks=chopmarks) # select those chopped segments which are inside the window mid <- midpoints.psp(chopped) ins <- inside.owin(mid$x, mid$y, window) retained <- chopped[ins] retained$window <- window return(retained) } spatstat.geom/R/discarea.R0000644000176200001440000000560114611065351015146 0ustar liggesusers# # discarea.R # # $Revision: 1.23 $ $Date: 2022/05/21 09:52:11 $ # # # Compute area of intersection between a disc and a window, # discpartarea <- function(X, r, W=as.owin(X)) { if(!missing(W)) { verifyclass(W, "owin") if(!inherits(X, "ppp")) X <- as.ppp(X, W) } verifyclass(X, "ppp") n <- X$n if(is.matrix(r) && nrow(r) != n) stop("the number of rows of r should match the number of points in X") if(!is.matrix(r)) { nr <- length(r) r <- matrix(r, nrow=n, ncol=nr, byrow=TRUE) } else { nr <- ncol(r) } W <- as.polygonal(W) # convert polygon to line segments Y <- edges(W) # remove vertical segments (contribution is zero) vert <- (Y$ends$x1 == Y$ends$x0) Y <- Y[!vert] ## go z <- .C(SG_discareapoly, nc=as.integer(n), xc=as.double(X$x), yc=as.double(X$y), nr=as.integer(nr), rmat=as.double(r), nseg=as.integer(Y$n), x0=as.double(Y$ends$x0), y0=as.double(Y$ends$y0), x1=as.double(Y$ends$x1), y1=as.double(Y$ends$y1), eps=as.double(.Machine$double.eps), out=as.double(numeric(length(r))), PACKAGE="spatstat.geom") areas <- matrix(z$out, n, nr) return(areas) } # Compute area of dilation of point pattern # using Dirichlet tessellation or distmap # (areas of other dilations using distmap) dilated.areas <- function(X, r, W=as.owin(X), ..., constrained=TRUE, exact=FALSE) { if(is.matrix(r)) { if(sum(dim(r) > 1) > 1L) stop("r should be a vector or single value") r <- as.vector(r) } if(exact && !is.ppp(X)) { exact <- FALSE warning("Option exact=TRUE is only available for ppp objects") } if(!constrained || is.null(W)) { # unconstrained dilation bb <- as.rectangle(X) W <- grow.rectangle(bb, max(r)) if(is.owin(X)) X <- rebound.owin(X, W) else X$window <- W } else W <- as.owin(W) if(!exact) { D <- distmap(X, ...) pixelarea <- D$xstep * D$ystep Dvals <- D[W, drop=TRUE] if(is.im(Dvals)) Dvals <- as.vector(as.matrix(Dvals)) Dvals <- Dvals[!is.na(Dvals)] rr <- c(-1, r) h <- cumsum(whist(Dvals, rr)) return(h * pixelarea) } npts <- npoints(X) nr <- length(r) if(npts == 0) return(numeric(nr)) else if(npts == 1L) return(discpartarea(X, r, W)) samebox <- (W$type == "rectangle") && isTRUE(all.equal(W, as.owin(X))) needclip <- constrained && !samebox X <- unique(X) dd <- dirichlet(X) til <- tiles(dd) #' some data points may not have a tile whichpoint <- as.integer(names(til)) partareas <- matrix(0, length(til), nr) for(j in seq_along(til)) { Tj <- til[[j]] if(needclip) Tj <- intersect.owin(Tj, W) i <- whichpoint[j] partareas[j,] <- discpartarea(X[i], r, Tj) } return(colSums(partareas)) } spatstat.geom/R/listof.R0000644000176200001440000000214714611065352014676 0ustar liggesusers# # listof.R # # Methods for class `listof' # # plot.listof is defined in plot.splitppp.R # "[<-.listof" <- function(x, i, value) { # invoke list method class(x) <- "list" x[i] <- value # then make it a 'listof' object too class(x) <- c("listof", class(x)) x } summary.listof <- function(object, ...) { x <- lapply(object, summary, ...) class(x) <- "summary.listof" x } print.summary.listof <- function(x, ...) { class(x) <- "listof" print(x) invisible(NULL) } listof <- function(...) { # warn.once("listof", # "The class listof will be Deprecated", # "in future versions of spatstat.", # "Use anylist or solist") stuff <- list(...) class(stuff) <- c("listof", class(stuff)) return(stuff) } as.listof <- function(x) { if(!is.list(x)) x <- list(x) if(!inherits(x, "listof")) class(x) <- c("listof", class(x)) # warn.once("listof", # "The class listof will be Deprecated", # "in future versions of spatstat.", # "Use anylist or solist") return(x) } as.layered.listof <- function(X) { layered(LayerList=X) } spatstat.geom/R/pp3.R0000644000176200001440000001537014611065352014102 0ustar liggesusers# # pp3.R # # class of three-dimensional point patterns in rectangular boxes # # $Revision: 1.33 $ $Date: 2020/12/19 05:25:06 $ # box3 <- function(xrange=c(0,1), yrange=xrange, zrange=yrange, unitname=NULL) { stopifnot(is.numeric(xrange) && length(xrange) == 2 && diff(xrange) > 0) stopifnot(is.numeric(yrange) && length(yrange) == 2 && diff(yrange) > 0) stopifnot(is.numeric(zrange) && length(zrange) == 2 && diff(zrange) > 0) out <- list(xrange=xrange, yrange=yrange, zrange=zrange, units=as.unitname(unitname)) class(out) <- "box3" return(out) } as.box3 <- function(...) { a <- list(...) n <- length(a) if(n == 0) stop("No arguments given") if(n == 1) { a <- a[[1]] if(inherits(a, "box3")) return(a) if(inherits(a, "pp3")) return(a$domain) if(inherits(a, "boxx")){ if(ncol(a$ranges)==3) return(box3(a$ranges[,1], a$ranges[,2], a$ranges[,3])) stop("Supplied boxx object does not have dimension three") } if(inherits(a, "ppx")) return(as.box3(a$domain)) if(is.numeric(a)) { if(length(a) == 6) return(box3(a[1:2], a[3:4], a[5:6])) stop(paste("Don't know how to interpret", length(a), "numbers as a box")) } if(!is.list(a)) stop("Don't know how to interpret data as a box") } return(do.call(box3, a)) } print.box3 <- function(x, ...) { bracket <- function(z) paste("[", paste(signif(z, 5), collapse=", "), "]", sep="") v <- paste(unlist(lapply(x[1:3], bracket)), collapse=" x ") s <- summary(unitname(x)) splat("Box:", v, s$plural, s$explain) invisible(NULL) } unitname.box3 <- function(x) { as.unitname(x$units) } "unitname<-.box3" <- function(x, value) { x$units <- as.unitname(value) return(x) } grow.box3 <- function(W, left, right=left) { as.box3(grow.boxx(as.boxx(W), left, right)) } eroded.volumes <- function(x, r) { UseMethod("eroded.volumes") } eroded.volumes.box3 <- function(x, r) { b <- as.box3(x) ax <- pmax.int(0, diff(b$xrange) - 2 * r) ay <- pmax.int(0, diff(b$yrange) - 2 * r) az <- pmax.int(0, diff(b$zrange) - 2 * r) ax * ay * az } shortside <- function(x) { UseMethod("shortside") } shortside.box3 <- function(x) { min(sidelengths(x)) } sidelengths <- function(x) { UseMethod("sidelengths") } sidelengths.box3 <- function(x) { with(x, c(diff(xrange), diff(yrange), diff(zrange))) } bounding.box3 <- function(...) { wins <- list(...) boxes <- lapply(wins, as.box3) xr <- range(unlist(lapply(boxes, getElement, name="xrange"))) yr <- range(unlist(lapply(boxes, getElement, name="yrange"))) zr <- range(unlist(lapply(boxes, getElement, name="zrange"))) box3(xr, yr, zr) } pp3 <- function(x, y, z, ..., marks=NULL) { stopifnot(is.numeric(x)) stopifnot(is.numeric(y)) stopifnot(is.numeric(z)) b <- as.box3(...) out <- ppx(data=data.frame(x=x,y=y,z=z), domain=b) class(out) <- c("pp3", class(out)) if(!is.null(marks)) marks(out) <- marks return(out) } domain.pp3 <- function(X, ...) { X$domain } is.pp3 <- function(x) { inherits(x, "pp3") } npoints.pp3 <- function(x) { nrow(x$data) } print.pp3 <- function(x, ...) { ism <- is.marked(x, dfok=TRUE) nx <- npoints(x) splat(if(ism) "Marked three-dimensional" else "Three-dimensional", "point pattern:", nx, ngettext(nx, "point", "points")) if(ism) { mks <- marks(x, dfok=TRUE) if(is.data.frame(mks) | is.hyperframe(mks)) { ## data frame of marks exhibitStringList("Mark variables:", names(mks)) } else { ## vector of marks if(is.factor(mks)) { exhibitStringList("Multitype, with levels =", levels(mks)) } else { ## Numeric, or could be dates if(inherits(mks, "Date")) { splat("marks are dates, of class", sQuote("Date")) } else if(inherits(mks, "POSIXt")) { splat("marks are dates, of class", sQuote("POSIXt")) } else { splat(paste0("marks are", if(is.numeric(mks)) " numeric," else NULL), "of storage type ", sQuote(typeof(mks))) } } } } print(x$domain) invisible(NULL) } summary.pp3 <- function(object, ...) { sd <- summary(object$data) np <- sd$ncases dom <- object$domain v <- volume.box3(dom) u <- summary(unitname(dom)) intens <- np/v out <- list(np=np, sumdat=sd, dom=dom, v=v, u=u, intensity=intens) class(out) <- "summary.pp3" return(out) } print.summary.pp3 <- function(x, ...) { splat("Three-dimensional point pattern") splat(x$np, ngettext(x$np, "point", "points")) print(x$dom) u <- x$u v <- x$v splat("Volume", v, "cubic", if(v == 1) u$singular else u$plural, u$explain) splat("Average intensity", x$intensity, "points per cubic", u$singular, u$explain) invisible(NULL) } plot.pp3 <- function(x, ..., eye=NULL, org=NULL, theta=25, phi=15, type=c("p", "n", "h"), box.back=list(col="pink"), box.front=list(col="blue", lwd=2)) { xname <- short.deparse(substitute(x)) type <- match.arg(type) # given arguments argh <- list(...) if(!missing(box.front)) argh$box.front <- box.front if(!missing(box.back)) argh$box.back <- box.back # Now apply formal defaults above formaldefaults <- list(box.front=box.front, box.back=box.back) #' coo <- as.matrix(coords(x)) xlim <- x$domain$xrange ylim <- x$domain$yrange zlim <- x$domain$zrange if(is.null(org)) org <- c(mean(xlim), mean(ylim), mean(zlim)) if(is.null(eye)) { theta <- theta * pi/180 phi <- phi * pi/180 d <- 2 * diameter(x$domain) eye <- org + d * c(cos(phi) * c(sin(theta), -cos(theta)), sin(phi)) } deefolts <- spatstat.options('par.pp3') ## determine default eye position and centre of view dont.complain.about(coo) do.call(plot3Dpoints, resolve.defaults(list(xyz=quote(coo), eye=eye, org=org, type=type), argh, deefolts, formaldefaults, list(main=xname, xlim=xlim, ylim=ylim, zlim=zlim))) } "[.pp3" <- function(x, i, drop=FALSE, ...) { answer <- NextMethod("[") if(is.ppx(answer)) class(answer) <- c("pp3", class(answer)) return(answer) } unitname.pp3 <- function(x) { unitname(x$domain) } "unitname<-.pp3" <- function(x, value) { d <- x$domain unitname(d) <- value x$domain <- d return(x) } diameter.box3 <- function(x) { stopifnot(inherits(x, "box3")) with(x, sqrt(diff(xrange)^2+diff(yrange)^2+diff(zrange)^2)) } volume <- function(x) { UseMethod("volume") } volume.box3 <- function(x) { stopifnot(inherits(x, "box3")) with(x, prod(diff(xrange), diff(yrange), diff(zrange))) } spatstat.geom/R/hyperframe.R0000644000176200001440000004712614735370477015564 0ustar liggesusers# # hyperframe.R # # $Revision: 1.80 $ $Date: 2025/01/02 01:48:03 $ # hyperframe <- local({ hyperframe <- function(..., row.names=NULL, check.rows=FALSE, check.names=TRUE, stringsAsFactors=NULL) { aarg <- list(...) nama <- names(aarg) stringsAsFactors <- resolve.stringsAsFactors(stringsAsFactors) ## number of columns (= variables) nvars <- length(aarg) if(nvars == 0) { ## zero columns - return result <- list(nvars=0, ncases=0, vname=character(0), vtype=factor(, levels=c("dfcolumn","hypercolumn","hyperatom")), vclass=character(0), df=data.frame(), hyperatoms=list(), hypercolumns=list()) class(result) <- c("hyperframe", class(result)) return(result) } ## check column names if(is.null(nama)) nama <- paste("V", 1:nvars, sep="") else if(any(unnamed <- (nama == ""))) nama[unnamed] <- paste("V", seq_len(sum(unnamed)), sep="") nama <- make.names(nama, unique=TRUE) names(aarg) <- nama ## Each argument must be either ## - a vector suitable as a column in a data frame ## - a list of objects of the same class ## - a single object of some class dfcolumns <- sapply(aarg, is.dfcolumn) hypercolumns <- sapply(aarg, is.hypercolumn) hyperatoms <- !(dfcolumns | hypercolumns) ## Determine number of rows (= cases) columns <- dfcolumns | hypercolumns if(!any(columns)) { ncases <- 1 } else { heights <- rep.int(1, nvars) heights[columns] <- lengths(aarg[columns]) u <- unique(heights) if(length(u) > 1) { u <- u[u != 1] if(length(u) > 1) stop(paste("Column lengths are inconsistent:", paste(u, collapse=","))) } ncases <- u if(ncases > 1 && all(heights[dfcolumns] == 1)) { ## force the data frame to have 'ncases' rows aarg[dfcolumns] <- lapply(aarg[dfcolumns], rep, ncases) heights[dfcolumns] <- ncases } if(any(stubs <- hypercolumns & (heights != ncases))) { ## hypercolumns of height 1 should be hyperatoms aarg[stubs] <- lapply(aarg[stubs], "[[", i=1L) hypercolumns[stubs] <- FALSE hyperatoms[stubs] <- TRUE } } ## Collect the data frame columns into a data frame if(!any(dfcolumns)) df <- as.data.frame(matrix(, ncases, 0)) else { df <- do.call(data.frame, append(aarg[dfcolumns], list(check.rows=check.rows, check.names=check.names, stringsAsFactors=stringsAsFactors))) names(df) <- nama[dfcolumns] } if(length(row.names)) row.names(df) <- row.names ## Storage type of each variable vtype <- character(nvars) vtype[dfcolumns] <- "dfcolumn" vtype[hypercolumns] <- "hypercolumn" vtype[hyperatoms] <- "hyperatom" vtype=factor(vtype, levels=c("dfcolumn","hypercolumn","hyperatom")) ## Class of each variable vclass <- character(nvars) if(any(dfcolumns)) vclass[dfcolumns] <- unlist(lapply(as.list(df), class1)) if(any(hyperatoms)) vclass[hyperatoms] <- unlist(lapply(aarg[hyperatoms], class1)) if(any(hypercolumns)) vclass[hypercolumns] <- unlist(lapply(aarg[hypercolumns], class1of1)) ## Put the result together result <- list(nvars=nvars, ncases=ncases, vname=nama, vtype=vtype, vclass=vclass, df=df, hyperatoms=aarg[hyperatoms], hypercolumns=aarg[hypercolumns]) class(result) <- c("hyperframe", class(result)) return(result) } dateclasses <- is.dfcolumn <- function(x) { is.atomic(x) && (is.vector(x) || is.factor(x) || inherits(x, c("POSIXlt", "POSIXct", "Date", "Surv"))) } is.hypercolumn <- function(x) { if(!is.list(x)) return(FALSE) if(inherits(x, c("listof", "anylist"))) return(TRUE) if(length(x) <= 1) return(TRUE) cla <- lapply(x, class) return(length(unique(cla)) == 1) } class1 <- function(x) { class(x)[1L] } class1of1 <- function(x) { class(x[[1L]])[1L] } hyperframe }) is.hyperframe <- function(x) inherits(x, "hyperframe") print.hyperframe <- function(x, ...) { ux <- unclass(x) nvars <- ux$nvars ncases <- ux$ncases if(nvars * ncases == 0) { splat("NULL hyperframe with", ncases, ngettext(ncases, "row (=case)", "rows (=cases)"), "and", nvars, ngettext(nvars, "column (=variable)", "columns (=variables)")) } else { if(waxlyrical('gory')) cat("Hyperframe:\n") print(as.data.frame(x, discard=FALSE), ...) } return(invisible(NULL)) } dim.hyperframe <- function(x) { with(unclass(x), c(ncases, nvars)) } summary.hyperframe <- function(object, ..., brief=FALSE) { x <- unclass(object) y <- list( nvars = x$nvars, ncases = x$ncases, dim = c(x$ncases, x$nvars), typeframe = data.frame(VariableName=x$vname, Class=x$vclass), storage = x$vtype, col.names = x$vname) classes <- x$vclass names(classes) <- x$vname y$classes <- classes # Ordinary data frame columns df <- x$df y$dfnames <- colnames(df) y$df <- if(length(df) > 0 && !brief) summary(df) else NULL y$row.names <- row.names(df) # insert into full array if(!brief && x$nvars > 0) { isobject <- (x$vtype != "dfcolumn") nobj <- sum(isobject) if(nobj == 0) { allcols <- y$df } else { nas <- rep(list(NA_character_), nobj) names(nas) <- x$vname[isobject] allcols <- do.call(cbind, append(list(y$df), nas)) acnames <- c(colnames(df), names(nas)) allcols <- allcols[ , match(x$vname, acnames), drop=FALSE] } pclass <- padtowidth(paren(classes), colnames(allcols), justify="right") allcols <- as.table(rbind(class=pclass, as.table(allcols))) row.names(allcols) <- rep("", nrow(allcols)) y$allcols <- allcols } class(y) <- c("summary.hyperframe", class(y)) return(y) } print.summary.hyperframe <- function(x, ...) { nvars <- x$nvars ncases <- x$ncases splat(if(nvars * ncases == 0) "NULL hyperframe" else "hyperframe", "with", ncases, ngettext(ncases, "row", "rows"), "and", nvars, ngettext(nvars, "column", "columns")) if(nvars == 0) return(invisible(NULL)) print(if(any(x$storage == "dfcolumn")) x$allcols else noquote(x$classes)) return(invisible(NULL)) } names.hyperframe <- function(x) { unclass(x)$vname } "names<-.hyperframe" <- function(x, value) { x <- unclass(x) stopifnot(is.character(value)) value <- make.names(value) if(length(value) != x$nvars) stop("Incorrect length for vector of names") vtype <- x$vtype names(x$df) <- value[vtype == "dfcolumn"] names(x$hyperatoms) <- value[vtype == "hyperatom"] names(x$hypercolumns) <- value[vtype == "hypercolumn"] x$vname <- value class(x) <- c("hyperframe", class(x)) return(x) } row.names.hyperframe <- function(x) { return(row.names(unclass(x)$df)) } "row.names<-.hyperframe" <- function(x, value) { y <- unclass(x) row.names(y$df) <- value class(y) <- c("hyperframe", class(y)) return(y) } dimnames.hyperframe <- function(x) { ux <- unclass(x) return(list(row.names(ux$df), ux$vname)) } "dimnames<-.hyperframe" <- function(x, value) { if(!is.list(value) || length(value) != 2 || !all(sapply(value, is.character))) stop("Invalid 'dimnames' for a hyperframe", call.=FALSE) rn <- value[[1L]] cn <- value[[2L]] d <- dim(x) if(length(rn) != d[1L]) stop(paste("Row names have wrong length:", length(rn), "should be", d[1L]), call.=FALSE) if(length(cn) != d[2L]) stop(paste("Column names have wrong length:", length(cn), "should be", d[2L]), call.=FALSE) y <- unclass(x) row.names(y$df) <- value[[1L]] y$vname <- value[[2]] class(y) <- c("hyperframe", class(y)) return(y) } ## conversion to hyperframe as.hyperframe <- function(x, ...) { UseMethod("as.hyperframe") } as.hyperframe.hyperframe <- function(x, ...) { return(x) } as.hyperframe.data.frame <- function(x, ..., stringsAsFactors=FALSE) { if(missing(x) || is.null(x)) { xlist <- rona <- NULL } else { rona <- row.names(x) xlist <- as.list(x) } do.call(hyperframe, resolve.defaults(xlist, list(...), list(row.names=rona, stringsAsFactors=stringsAsFactors), .StripNull=TRUE)) } as.hyperframe.anylist <- as.hyperframe.listof <- function(x, ...) { if(!missing(x)) { xname <- sensiblevarname(short.deparse(substitute(x)), "x") xlist <- list(x) names(xlist) <- xname } else xlist <- NULL do.call(hyperframe, resolve.defaults( xlist, list(...), .StripNull=TRUE)) } as.hyperframe.default <- function(x, ...) { as.hyperframe(as.data.frame(x, ...)) } #### conversion to other types as.data.frame.hyperframe <- function(x, row.names = NULL, optional = FALSE, ..., discard=TRUE, warn=TRUE) { ux <- unclass(x) if(is.null(row.names)) row.names <- row.names(ux$df) vtype <- ux$vtype vclass <- ux$vclass dfcol <- (vtype == "dfcolumn") if(discard) { nhyper <- sum(!dfcol) if(nhyper > 0 && warn) warning(paste(nhyper, ngettext(nhyper, "variable", "variables"), "discarded in conversion to data frame")) df <- as.data.frame(ux$df, row.names=row.names, optional=optional, ...) } else { lx <- as.list(x) nrows <- ux$ncases vclassstring <- paren(vclass) if(any(!dfcol)) lx[!dfcol] <- lapply(as.list(vclassstring[!dfcol]), rep.int, times=nrows) df <- do.call(data.frame, append(lx, list(row.names=row.names))) colnames(df) <- ux$vname } return(df) } as.list.hyperframe <- function(x, ...) { ux <- unclass(x) out <- vector(mode="list", length=ux$nvars) vtype <- ux$vtype df <- ux$df if(any(dfcol <- (vtype == "dfcolumn"))) out[dfcol] <- as.list(df) if(any(hypcol <- (vtype == "hypercolumn"))) { hc <- lapply(ux$hypercolumns, as.solist, demote=TRUE) out[hypcol] <- hc } if(any(hatom <- (vtype == "hyperatom"))) { ha <- ux$hyperatoms names(ha) <- NULL hacol <- lapply(ha, list) hacol <- lapply(hacol, rep.int, times=ux$ncases) hacol <- lapply(hacol, as.solist, demote=TRUE) out[hatom] <- hacol } out <- lapply(out, "names<-", value=row.names(df)) names(out) <- names(x) return(out) } # evaluation # eval.hyper <- function(e, h, simplify=TRUE, ee=NULL) { # .Deprecated("with.hyperframe", package="spatstat") # if(is.null(ee)) # ee <- as.expression(substitute(e)) # with.hyperframe(h, simplify=simplify, ee=ee) # } with.hyperframe <- function(data, expr, ..., simplify=TRUE, ee=NULL, enclos=NULL) { if(!inherits(data, "hyperframe")) stop("data must be a hyperframe") if(is.null(ee)) ee <- as.expression(substitute(expr)) if(is.null(enclos)) enclos <- parent.frame() n <- nrow(data) out <- vector(mode="list", length=n) datalist <- as.list(data) for(i in 1:n) { rowi <- lapply(datalist, "[[", i=i) # ensures the result is always a list outi <- eval(ee, rowi, enclos) if(!is.null(outi)) out[[i]] <- outi } names(out) <- row.names(data) if(simplify && all(unlist(lapply(out, is.vector)))) { # if all results are atomic vectors of equal length, # return a matrix or vector. lenfs <- lengths(out) if(all(unlist(lapply(out, is.atomic))) && length(unique(lenfs)) == 1) { out <- t(as.matrix(as.data.frame(out))) row.names(out) <- row.names(data) out <- out[,,drop=TRUE] return(out) } } out <- hyperframe(result=out, row.names=row.names(data))$result return(out) } cbind.hyperframe <- function(...) { aarg <- list(...) narg <- length(aarg) if(narg == 0) return(hyperframe()) namarg <- names(aarg) if(is.null(namarg)) namarg <- rep.int("", narg) ishyper <- unlist(lapply(aarg, inherits, what="hyperframe")) isdf <- unlist(lapply(aarg, inherits, what="data.frame")) columns <- list() for(i in 1:narg) { if(ishyper[i] || isdf[i]){ if(ncol(aarg[[i]]) > 0) { newcolumns <- as.list(aarg[[i]]) if(namarg[i] != "") names(newcolumns) <- paste(namarg[i], ".", names(newcolumns), sep="") columns <- append(columns, newcolumns) } } else { nextcolumn <- list(aarg[[i]]) names(nextcolumn) <- namarg[i] columns <- append(columns, nextcolumn) } } result <- do.call(hyperframe, columns) ## tack on row names rona <- lapply(aarg, row.names) good <- (lengths(rona) == nrow(result)) if(any(good)) row.names(result) <- rona[[min(which(good))]] return(result) } rbind.hyperframe <- function(...) { argh <- list(...) if(length(argh) == 0) return(NULL) # convert them all to hyperframes argh <- lapply(argh, as.hyperframe) # nargh <- length(argh) if(nargh == 1) return(argh[[1L]]) # check for compatibility of dimensions & names dfs <- lapply(argh, as.data.frame, discard=FALSE) dfall <- do.call(rbind, dfs) # check that data frame columns also match dfs0 <- lapply(argh, as.data.frame, discard=TRUE, warn=FALSE) df0all <- do.call(rbind, dfs0) # assemble data rslt <- list() nam <- names(dfall) nam0 <- names(df0all) for(k in seq_along(nam)) { nama <- nam[k] if(nama %in% nam0) { # data frame column: already made rslt[[k]] <- dfall[,k] } else { ## hypercolumns or hyperatoms: extract them hdata <- lapply(argh, "[", j=nama, drop=FALSE) hdata <- lapply(lapply(hdata, as.list), getElement, name=nama) ## bind them hh <- Reduce(append, hdata) rslt[[k]] <- hh } } ## make hyperframe names(rslt) <- nam rona <- row.names(dfall) out <- do.call(hyperframe, append(rslt, list(stringsAsFactors=FALSE, row.names=rona))) return(out) } plot.hyperframe <- function(x, e, ..., main, arrange=TRUE, nrows=NULL, ncols=NULL, parargs=list(mar=mar * marsize), marsize=1, mar=c(1,1,3,1)) { xname <- short.deparse(substitute(x)) main <- if(!missing(main)) main else xname mar <- rep(mar, 4)[1:4] if(missing(e)) { # default: plot first column that contains objects ok <- (summary(x)$storage %in% c("hypercolumn", "hyperatom")) if(any(ok)) { j <- min(which(ok)) x <- x[,j, drop=TRUE, strip=FALSE] x <- as.solist(x, demote=TRUE) plot(x, ..., main=main, arrange=arrange, nrows=nrows, ncols=ncols) return(invisible(NULL)) } else { # hyperframe does not contain any objects # invoke plot.data.frame x <- as.data.frame(x) plot(x, ..., main=main) return(invisible(NULL)) } } if(!is.language(e)) stop(paste("Argument e should be a call or an expression;", "use quote(...) or expression(...)")) ee <- as.expression(e) if(!arrange) { # No arrangement specified: just evaluate the plot expression 'nr' times with(x, ee=ee) return(invisible(NULL)) } # Arrangement # Decide whether to plot a main header banner <- (sum(nchar(as.character(main))) > 0) if(length(main) > 1) main <- paste(main, collapse="\n") nlines <- if(!is.character(main)) 1 else length(unlist(strsplit(main, "\n"))) # determine arrangement of plots # arrange like mfrow(nrows, ncols) plus a banner at the top n <- summary(x)$ncases if(is.null(nrows) && is.null(ncols)) { nrows <- as.integer(floor(sqrt(n))) ncols <- as.integer(ceiling(n/nrows)) } else if(!is.null(nrows) && is.null(ncols)) ncols <- as.integer(ceiling(n/nrows)) else if(is.null(nrows) && !is.null(ncols)) nrows <- as.integer(ceiling(n/ncols)) else stopifnot(nrows * ncols >= length(x)) nblank <- ncols * nrows - n # declare layout mat <- matrix(c(seq_len(n), numeric(nblank)), byrow=TRUE, ncol=ncols, nrow=nrows) heights <- rep.int(1, nrows) if(banner) { # Increment existing panel numbers # New panel 1 is the banner panels <- (mat > 0) mat[panels] <- mat[panels] + 1L mat <- rbind(rep.int(1,ncols), mat) heights <- c(0.1 * (1 + nlines), heights) } # initialise plot layout(mat, heights=heights) # plot banner if(banner) { opa <- par(mar=rep.int(0,4), xpd=TRUE) on.exit(par(opa)) plot(numeric(0),numeric(0),type="n",ann=FALSE,axes=FALSE, xlim=c(-1,1),ylim=c(-1,1)) cex <- resolve.defaults(list(...), list(cex.title=2))$cex.title text(0,0,main, cex=cex) } # plot panels npa <- do.call(par, parargs) if(!banner) on.exit(par(npa)) with(x, ee=ee) # revert layout(1) return(invisible(NULL)) } str.hyperframe <- function(object, ...) { d <- dim(object) x <- unclass(object) argh <- resolve.defaults(list(...), list(nest.lev=0, indent.str=" ..")) cat(paste("'hyperframe':\t", d[1L], ngettext(d[1L], "row", "rows"), "and", d[2L], ngettext(d[2L], "column", "columns"), "\n")) nr <- d[1L] nc <- d[2L] if(nc > 0) { vname <- x$vname vclass <- x$vclass vtype <- as.character(x$vtype) indentstring <- with(argh, paste(rep.int(indent.str, nest.lev), collapse="")) for(j in 1:nc) { tag <- paste("$", vname[j]) switch(vtype[j], dfcolumn={ desc <- vclass[j] if(nr > 0) { vals <- object[1:min(nr,3),j,drop=TRUE] vals <- paste(paste(format(vals), collapse=" "), "...") } else vals <- "" }, hypercolumn=, hyperatom={ desc <- "objects of class" vals <- vclass[j] }) cat(paste(paste(indentstring, tag, sep=""), ":", desc, vals, "\n")) } } return(invisible(NULL)) } subset.hyperframe <- function(x, subset, select, ...) { stopifnot(is.hyperframe(x)) r <- if(missing(subset)) { rep_len(TRUE, nrow(x)) } else { r <- eval(substitute( with(x, e, enclos=parent.frame()), list(e=substitute(subset)))) if (!is.logical(r)) stop("'subset' must be logical") r & !is.na(r) } vars <- if(missing(select)) { TRUE } else { nl <- as.list(seq_len(ncol(x))) names(nl) <- names(x) eval(substitute(select), nl, parent.frame()) } nama <- names(x) names(nama) <- nama vars <- nama[vars] z <- x[i=r, j=vars, ...] return(z) } head.hyperframe <- function (x, n = 6L, ...) { stopifnot(length(n) == 1L) n <- if(n < 0L) max(nrow(x) + n, 0L) else min(n, nrow(x)) x[seq_len(n), , drop = FALSE] } tail.hyperframe <- function(x, n = 6L, ...) { stopifnot(length(n) == 1L) nrx <- nrow(x) n <- if(n < 0L) max(nrx + n, 0L) else min(n, nrx) sel <- seq.int(to = nrx, length.out = n) x[sel, , drop = FALSE] } edit.hyperframe <- function(name, ...) { x <- name isdf <- unclass(x)$vtype == "dfcolumn" if(!any(isdf)) { warning("No columns of editable data", call.=FALSE) return(x) } y <- x[,isdf] ynew <- edit(as.data.frame(y), ...) xnew <- x for(na in names(ynew)) xnew[,na] <- ynew[,na] losenames <- setdiff(names(y), names(ynew)) for(na in losenames) xnew[,na] <- NULL return(xnew) } spatstat.geom/R/convexify.R0000644000176200001440000000076014611065351015406 0ustar liggesusers## ## convexify.R ## ## $Revision: 1.2 $ $Date: 2020/03/16 10:28:51 $ convexify <- function(W, eps) { if(!is.polygonal(W)) { if(missing(eps)) eps <- diameter(Frame(W))/20 W <- simplify.owin(W, eps) } e <- edges(W) len <- lengths_psp(e) ang <- angles.psp(e, directed=TRUE) df <- data.frame(ang=ang, len=len) df <- df[order(df$ang), ] df <- within(df, { dx <- len * cos(ang); dy <- len * sin(ang)}) owin(poly=with(df, list(x=cumsum(c(0,dx)), y=cumsum(c(0,dy))))) } spatstat.geom/R/rescale.R0000644000176200001440000000321014611065352015004 0ustar liggesusers# # # rescale.R # # $Revision: 1.8 $ $Date: 2019/02/10 06:42:26 $ # # rescale <- function(X, s, unitname) { UseMethod("rescale") } rescale.ppp <- function(X, s, unitname) { if(missing(unitname)) unitname <- NULL if(missing(s) || is.null(s)) s <- 1/unitname(X)$multiplier Y <- affine.ppp(X, mat=diag(c(1/s,1/s)), rescue=FALSE) unitname(Y) <- rescale(unitname(X), s, unitname) return(Y) } rescale.owin <- function(X, s, unitname) { if(missing(unitname)) unitname <- NULL if(missing(s) || is.null(s)) s <- 1/unitname(X)$multiplier Y <- affine.owin(X, mat=diag(c(1/s,1/s)), rescue=FALSE) unitname(Y) <- rescale(unitname(X), s, unitname) return(Y) } rescale.im <- function(X, s, unitname) { if(missing(unitname)) unitname <- NULL if(missing(s) || is.null(s)) s <- 1/unitname(X)$multiplier Y <- X Y$xrange <- X$xrange/s Y$yrange <- X$yrange/s Y$xstep <- X$xstep/s Y$ystep <- X$ystep/s Y$xcol <- X$xcol/s Y$yrow <- X$yrow/s unitname(Y) <- rescale(unitname(X), s, unitname) return(Y) } rescale.psp <- function(X, s, unitname) { if(missing(unitname)) unitname <- NULL if(missing(s) || is.null(s)) s <- 1/unitname(X)$multiplier Y <- affine.psp(X, mat=diag(c(1/s,1/s)), rescue=FALSE) unitname(Y) <- rescale(unitname(X), s, unitname) return(Y) } rescale.unitname <- function(X, s, unitname) { if(!missing(unitname) && !is.null(unitname)) return(as.unitname(unitname)) if(summary(X)$vanilla) return(X) if(missing(s)) { X$multiplier <- 1 } else { if(!is.numeric(s) || length(s) != 1 || s <= 0) stop("s should be a positive number") X$multiplier <- s * X$multiplier } return(X) } spatstat.geom/R/pixellate.R0000644000176200001440000001564014611065352015367 0ustar liggesusers# # pixellate.R # # $Revision: 1.30 $ $Date: 2022/05/21 09:52:11 $ # # pixellate convert an object to a pixel image # # pixellate.ppp convert a point pattern to a pixel image # (pixel value = number of points in pixel) # # pixellate.owin convert a window to a pixel image # (pixel value = area of intersection with pixel) # pixellate <- function(x, ...) { UseMethod("pixellate") } pixellate.ppp <- function(x, W=NULL, ..., weights=NULL, padzero=FALSE, fractional=FALSE, preserve=FALSE, DivideByPixelArea=FALSE, savemap=FALSE) { verifyclass(x, "ppp") if(is.null(W)) W <- Window(x) isrect <- is.rectangle(W) preserve <- preserve && !isrect iscount <- is.null(weights) && !fractional && !preserve W <- do.call.matched(as.mask, resolve.defaults(list(...), list(w=quote(W)))) nx <- npoints(x) insideW <- W$m dimW <- W$dim nr <- dimW[1L] nc <- dimW[2L] xcolW <- W$xcol yrowW <- W$yrow xrangeW <- W$xrange yrangeW <- W$yrange unitsW <- unitname(W) # multiple columns of weights? if(is.data.frame(weights) || is.matrix(weights)) { k <- ncol(weights) stopifnot(nrow(weights) == npoints(x)) weights <- if(k == 1) as.vector(weights) else as.data.frame(weights) } else { k <- 1 nw <- length(weights) if(nw == 0) weights <- NULL else check.nvector(weights, nx, oneok=TRUE, naok=TRUE, vname="weights") if(nw == 1) weights <- rep(weights, nx) } # handle empty point pattern if(nx == 0) { zerovalue <- if(iscount) 0L else as.double(0) zeroimage <- as.im(zerovalue, W) if(padzero) # map NA to 0 zeroimage <- na.handle.im(zeroimage, zerovalue) result <- zeroimage if(k > 1) { result <- as.solist(rep(list(zeroimage), k)) names(result) <- colnames(weights) } return(result) } # map points to pixels xx <- x$x yy <- x$y if(!fractional) { #' map (x,y) to nearest raster point pixels <- if(preserve) nearest.valid.pixel(xx, yy, W) else nearest.raster.point(xx, yy, W) rowfac <- factor(pixels$row, levels=1:nr) colfac <- factor(pixels$col, levels=1:nc) } else { #' attribute fractional weights to the 4 pixel centres surrounding (x,y) #' find surrounding pixel centres jj <- findInterval(xx, xcolW, rightmost.closed=TRUE) ii <- findInterval(yy, yrowW, rightmost.closed=TRUE) jleft <- pmax(jj, 1) jright <- pmin(jj + 1, nr) ibot <- pmax(ii, 1) itop <- pmin(ii+1, nc) #' compute fractional weights wleft <- pmin(1, abs(xcolW[jright] - xx)/W$xstep) wright <- 1 - wleft wbot <- pmin(1, abs(yrowW[itop] - yy)/W$ystep) wtop <- 1 - wbot #' pack together ww <- c(wleft * wbot, wleft * wtop, wright * wbot, wright * wtop) rowfac <- factor(c(ibot, itop, ibot, itop), levels=1:nr) colfac <- factor(c(jleft, jleft, jright, jright), levels=1:nc) if(preserve) { #' normalise fractions for each data point to sum to 1 inside window ok <- insideW[cbind(as.integer(rowfac), as.integer(colfac))] wwok <- ww * ok denom <- .colSums(wwok, 4, nx, na.rm=TRUE) recip <- ifelse(denom == 0, 1, 1/denom) ww <- wwok * rep(recip, each=4) } #' data weights must be replicated if(is.null(weights)) { weights <- ww } else if(k == 1) { weights <- ww * rep(weights, 4) } else { weights <- ww * apply(weights, 2, rep, times=4) } } #' sum weights if(is.null(weights)) { ta <- table(row = rowfac, col = colfac) } else if(k == 1) { ta <- tapplysum(weights, list(row = rowfac, col=colfac)) } else { ta <- list() for(j in 1:k) { ta[[j]] <- tapplysum(weights[,j], list(row = rowfac, col=colfac)) } } #' divide by pixel area? if(DivideByPixelArea) { pixelarea <- W$xstep * W$ystep if(k == 1) { ta <- ta/pixelarea } else { ta <- lapply(ta, "/", e2=pixelarea) } } # pack up as image(s) if(k == 1) { # single image # clip to window of data if(!padzero) ta[!insideW] <- NA out <- im(ta, xcol = xcolW, yrow = yrowW, xrange = xrangeW, yrange = yrangeW, unitname=unitsW) } else { # case k > 1 # create template image to reduce overhead template <- im(ta[[1L]], xcol = xcolW, yrow = yrowW, xrange = xrangeW, yrange = yrangeW, unitname=unitsW) out <- list() for(j in 1:k) { taj <- ta[[j]] # clip to window of data if(!padzero) taj[!insideW] <- NA # copy template and reassign pixel values outj <- template outj$v <- taj # store out[[j]] <- outj } out <- as.solist(out) names(out) <- names(weights) } if(savemap) attr(out, "map") <- cbind(row=as.integer(rowfac), col=as.integer(colfac)) return(out) } pixellate.owin <- function(x, W=NULL, ..., DivideByPixelArea=FALSE) { stopifnot(is.owin(x)) P <- as.polygonal(x) R <- as.rectangle(x) if(is.null(W)) W <- R else if(!is.subset.owin(R, as.rectangle(W))) stop("W does not cover the domain of x") W <- do.call.matched(as.mask, resolve.defaults(list(...), list(w=quote(W)))) ## compute Zmat <- polytileareaEngine(P, W$xrange, W$yrange, nx=W$dim[2L], ny=W$dim[1L], DivideByPixelArea) ## convert to image Z <- im(Zmat, xcol=W$xcol, yrow=W$yrow, xrange=W$xrange, yrange=W$yrange, unitname=unitname(W)) return(Z) } polytileareaEngine <- function(P, xrange, yrange, nx, ny, DivideByPixelArea=FALSE) { x0 <- xrange[1L] y0 <- yrange[1L] dx <- diff(xrange)/nx dy <- diff(yrange)/ny # process each component polygon Z <- matrix(0.0, ny, nx) B <- P$bdry for(i in seq_along(B)) { PP <- B[[i]] # transform so that pixels become unit squares QQ <- affinexypolygon(PP, vec = c(-x0, -y0)) RR <- affinexypolygon(QQ, mat = diag(1/c(dx, dy))) # xx <- RR$x yy <- RR$y nn <- length(xx) # close polygon xx <- c(xx, xx[1L]) yy <- c(yy, yy[1L]) nn <- nn+1 ## call C routine zz <- .C(SG_poly2imA, ncol=as.integer(nx), nrow=as.integer(ny), xpoly=as.double(xx), ypoly=as.double(yy), npoly=as.integer(nn), out=as.double(numeric(nx * ny)), status=as.integer(integer(1L)), PACKAGE="spatstat.geom") if(zz$status != 0) stop("Internal error") # increment output Z[] <- Z[] + zz$out } if(!DivideByPixelArea) { #' revert to original scale pixelarea <- dx * dy Z <- Z * pixelarea } return(Z) } spatstat.geom/R/boundingbox.R0000644000176200001440000001473414611065351015720 0ustar liggesusers## ## boundingbox.R ## ## $Revision: 1.12 $ $Date: 2024/02/04 08:04:51 $ # bounding.box <- function(...) { # .Deprecated("boundingbox", "spatstat") # boundingbox(...) # } boundingbox <- function(...) { ## remove any NULL arguments arglist <- list(...) if(any(isnull <- sapply(arglist, is.null))) { if(length(arglist[!isnull])) return(do.call(boundingbox, arglist[!isnull])) stop("No non-null arguments given.\n") } UseMethod("boundingbox") } boundingbox.solist <- function(...) { argh <- list(...) issl <- sapply(argh, inherits, what="solist") yarg <- c(do.call(c, argh[issl]), argh[!issl]) do.call(bbEngine, yarg) } boundingbox.ppp <- boundingbox.psp <- boundingbox.owin <- boundingbox.list <- boundingbox.linnet <- boundingbox.lpp <- boundingbox.im <- function(...) { bbEngine(...) } recognise.spatstat.type <- local({ knowntypes <- c("ppp","psp","owin","im", "lpp", "linnet") function(x) { for(kt in knowntypes) if(inherits(x, kt)) return(kt) if(is.list(x) && checkfields(x, c("x", "y")) && is.numeric(x$x) && is.numeric(x$y) && is.vector(x$x) && is.vector(x$y) && length(x$x) == length(x$y)) return("listxy") aso <- try(as.owin(x), silent=TRUE) if(!inherits(aso, "try-error")) return("as.owin") return("unknown") } }) bbEngine <- local({ bb.listxy <- function(X) owinInternalRect(range(X$x), range(X$y)) bb.linnet <- function(X) boundingbox(vertices(X)) bb.lpp <- function(X) boundingbox(as.ppp(X)) bbEngine <- function(...) { wins <- list(...) ## first detect any numeric vector arguments if(any(isnumvec <- unlist(lapply(wins, is.vector)) & unlist(lapply(wins, is.numeric)))) { ## invoke default method on these arguments bb <- do.call(boundingbox, wins[isnumvec]) ## repack wins <- append(wins[!isnumvec], list(bb)) } if(length(wins) > 1) { ## multiple arguments -- compute bounding box for each argument. objtype <- unlist(lapply(wins, recognise.spatstat.type)) nbad <- sum(objtype == "unknown") if(nbad > 0) { whinge <- paste("Function boundingbox called with", nbad,"unrecognised", ngettext(nbad,"argument","arguments")) stop(whinge, call.=FALSE) } if(any(isppp <- (objtype == "ppp"))) wins[isppp] <- lapply(wins[isppp], boundingbox) if(any(islistxy <- (objtype == "listxy"))) wins[islistxy] <- lapply(wins[islistxy], bb.listxy) if(any(isnet <- (objtype == "linnet"))) wins[isnet] <- lapply(wins[isnet], bb.linnet) if(any(islpp <- (objtype == "lpp"))) wins[islpp] <- lapply(wins[islpp], bb.lpp) ## then convert all windows to owin wins <- lapply(wins, as.owin) ## then take bounding box of each window boxes <- lapply(wins, boundingbox) ## discard NULL values isnull <- unlist(lapply(boxes, is.null)) boxes <- boxes[!isnull] ## take bounding box of these boxes xrange <- range(unlist(lapply(boxes, getElement, name="xrange"))) yrange <- range(unlist(lapply(boxes, getElement, name="yrange"))) W <- owinInternalRect(xrange, yrange) ## If all of the windows have a common unit name, give ## that unit name to the bounding box. youse <- unique(t(sapply(boxes,unitname))) if(nrow(youse)==1) { ute <- unlist(youse[1L,]) unitname(W) <- ute } return(W) } ## single argument w <- wins[[1L]] if(is.null(w)) return(NULL) wtype <- recognise.spatstat.type(w) ## point pattern? if(wtype == "ppp") return(boundingbox(coords(w))) ## line segment pattern? if(wtype == "psp") return(boundingbox(endpoints.psp(w))) ## list(x,y) if(wtype == "listxy") return(bb.listxy(w)) if(wtype == "linnet") w <- return(bb.linnet(w)) if(wtype == "lpp") w <- return(bb.lpp(w)) ## convert to window w <- as.owin(w) ## determine a tight bounding box for the window w switch(w$type, rectangle = { return(w) }, polygonal = { bdry <- w$bdry if(length(bdry) == 0) return(NULL) xr <- range(unlist(lapply(bdry, rangeofx))) yr <- range(unlist(lapply(bdry, rangeofy))) return(owinInternalRect(xr, yr, unitname=unitname(w))) }, mask = { m <- w$m x <- rasterx.mask(w) y <- rastery.mask(w) xr <- range(x[m]) + c(-1,1) * w$xstep/2 yr <- range(y[m]) + c(-1,1) * w$ystep/2 return(owinInternalRect(xr, yr, unitname=unitname(w))) }, stop("unrecognised window type", w$type) ) } rangeofx <- function(a) range(a$x) rangeofy <- function(a) range(a$y) bbEngine }) boundingbox.default <- local({ bb.listxy <- function(X) owinInternalRect(range(X$x), range(X$y)) boundingbox.default <- function(...) { arglist <- list(...) bb <- NULL if(length(arglist) == 0) return(bb) ## handle numeric vector arguments if(any(isnumvec <- unlist(lapply(arglist, is.vector)) & unlist(lapply(arglist, is.numeric)))) { nvec <- sum(isnumvec) if(nvec != 2) stop(paste("boundingbox.default expects 2 numeric vectors:", nvec, "were supplied"), call.=FALSE) vecs <- arglist[isnumvec] x <- vecs[[1L]] y <- vecs[[2L]] bb <- if(length(x) == length(y)) owinInternalRect(range(x), range(y)) else NULL arglist <- arglist[!isnumvec] } if(length(arglist) == 0) return(bb) ## other objects are present objtype <- unlist(lapply(arglist, recognise.spatstat.type)) ## Unrecognised? nbad <- sum(objtype == "unknown") if(nbad > 0) { whinge <- paste("Function boundingbox called with", nbad,"unrecognised", ngettext(nbad,"argument","arguments")) stop(whinge, call.=FALSE) } if(any(aso <- (objtype == "as.owin"))) { ## promote objects to owin (to avoid infinite recursion!) arglist[aso] <- lapply(arglist[aso], as.owin) } if(any(lxy <- (objtype == "listxy"))) { ## handle list(x,y) objects arglist[lxy] <- lapply(arglist[lxy], bb.listxy) } result <- do.call(boundingbox, if(is.null(bb)) arglist else append(list(bb), arglist)) return(result) } boundingbox.default }) spatstat.geom/R/plot.im.R0000644000176200001440000011505014723456312014762 0ustar liggesusers# # plot.im.R # # $Revision: 1.161 $ $Date: 2024/12/03 01:19:40 $ # # Plotting code for pixel images # # plot.im # image.im # contour.im # ########################################################################### plot.im <- local({ ## auxiliary functions image.doit <- function(imagedata, ..., add=FALSE, show.all=!add, extrargs=graphicsPars("image"), W, addcontour=FALSE, contourargs=list(), args.contour=list(), # legacy - undocumented workaround=FALSE) { aarg <- resolve.defaults(..., list(add=add, show.all=show.all)) ## if(add && show.all) { ## set up the window space *with* the main title ## using the same code as plot.owin, for consistency force(W) do.call.matched(plot.owin, resolve.defaults(list(x=quote(W), type="n"), aarg), extrargs=graphicsPars("owin")) } if(workaround && isTRUE(aarg$useRaster)) { #' workaround for bug 16035 #' detect reversed coordinates usr <- par('usr') xrev <- (diff(usr[1:2]) < 0) yrev <- (diff(usr[3:4]) < 0) if(xrev || yrev) { #' flip matrix of pixel values, because the device driver does not z <- imagedata$z d <- dim(z) # z is in the orientation expected for image.default if(xrev) z <- z[d[1]:1, , drop=FALSE] if(yrev) z <- z[ , d[2]:1, drop=FALSE] imagedata$z <- z } } extrargs <- setdiff(extrargs, c("claim.title.space", "box")) if(!is.na(k <- match("adj.main", names(aarg)))) names(aarg)[k] <- "adj" z <- do.call.matched(image.default, append(imagedata, aarg), extrargs=extrargs) if(addcontour) { do.call(do.contour, resolve.defaults(imagedata, list(add=TRUE), contourargs, args.contour, list(col=par('fg')), aarg, .StripNull=TRUE)) } return(z) } do.contour <- function(x, y, z, ..., nlevels=10, levels=NULL, labels=NULL, drawlabels=TRUE, values.are.log=FALSE) { nx <- length(x) ny <- length(y) nz <- dim(z) if(nx > nz[1]) { if(nz[1] == 1) { z <- rbind(z, z) nz <- dim(z) drawlabels <- FALSE } else { x <- (x[-1] + x[-nx])/2 nx <- nx-1 } } if(ny > nz[2]) { if(nz[2] == 1) { z <- cbind(z, z) nz <- dim(z) drawlabels <- FALSE } else { y <- (y[-1] + y[-ny])/2 ny <- ny-1 } } if(values.are.log) { ## ................ logarithmic case ........................ ## z is log10 of actual value if(!is.null(levels)) { labels <- paste(levels) levels <- log10(levels) } else { logra <- range(z, finite=TRUE) ## default levels commensurate with logarithmic colour scale dlr <- diff(logra) if(dlr > 1.5) { ## usual case - data ranges over several powers of 10 wholepowers <- 10^(floor(logra[1]):ceiling(logra[2])) levelsperdecade <- nlevels/max(1, length(wholepowers)-1) if(levelsperdecade >= 1) { ## At least one contour level for every power of 10 ## Decide on leading digits if(levelsperdecade < 1.5) { leadingdigits <- 1 } else if(levelsperdecade < 2.5) { leadingdigits <- c(1,3) } else if(levelsperdecade < 3.5) { leadingdigits <- c(1,2,5) } else { ## use fractional powers of 10, equally spaced on log scale leadingdigits <- 10^seq(0, 1, length.out=ceiling(levelsperdecade)+1) leadingdigits <- leadingdigits[-length(leadingdigits)] leadingdigits <- round(leadingdigits, max(2, ceiling(log10(levelsperdecade)))) } explevels <- sort(unique(as.numeric(outer(wholepowers, leadingdigits, "*")))) } else { ## more than one power of 10 between successive contour levels explevels <- wholepowers thinperiod <- max(1L, floor(1/levelsperdecade)) if(thinperiod > 1) { i <- floor((thinperiod+1)/2) explevels <- explevels[seq_along(explevels) %% thinperiod == i] } } } else { ## Small range: use standard (non-logarithmic scale) values explevels <- pretty(10^logra, nlevels) } ## restrict to actual range explevels <- explevels[inside.range(explevels, 10^logra)] if(length(explevels) == 0) explevels <- 10^mean(logra) ## finally define levels and labels labels <- paste(explevels) levels <- log10(explevels) } ## ................ end logarithmic case ........................ } do.call.matched(contour.default, resolve.defaults(list(x=x, y=y, z=z, ..., nlevels=nlevels, levels=levels, labels=labels, drawlabels=drawlabels), .StripNull=TRUE)) } do.box.etc <- function(bb, add, argh) { do.call(box.etc, append(list(bb=bb, add=add), argh)) } box.etc <- function(bb, ..., add=FALSE, box=!add, axes=FALSE, ann=FALSE, xlab="", ylab="") { # axes for image xr <- bb$xrange yr <- bb$yrange if(box) rect(xr[1], yr[1], xr[2], yr[2]) if(axes) { px <- prettyinside(xr) py <- prettyinside(yr) do.call.plotfun(graphics::axis, resolve.defaults( list(side=1, at=px), list(...), list(pos=yr[1])), extrargs=graphicsPars("axis")) do.call.plotfun(graphics::axis, resolve.defaults( list(side=2, at=py), list(...), list(pos=xr[1])), extrargs=graphicsPars("axis")) } ## axis labels xlab, ylab if(ann) { dox <- any(nzchar(xlab)) doy <- any(nzchar(ylab)) line0 <- if(axes) 1 else 0 if(dox || doy) { mtargs <- resolve.defaults(list(...), list(line=line0)) if(dox) do.call.matched(mtext, append(list(text=xlab, side=1), mtargs)) if(doy) do.call.matched(mtext, append(list(text=ylab, side=2), mtargs)) } } } clamp <- function(x, v, tol=0.02 * diff(v)) { ok <- (x >= v[1] - tol) & (x <= v[2] + tol) x[ok] } cellbreaks <- function(x, dx) { nx <- length(x) seq(x[1] - dx/2, x[nx] + dx/2, length.out=nx+1) } log10orNA <- function(x) { y <- rep(NA_real_, length(x)) ok <- !is.na(x) & (x > 0) y[ok] <- log10(x[ok]) return(y) } Ticks <- function(usr, log=FALSE, nint=NULL, ..., clip=TRUE) { #' modification of grDevices::axisTicks #' constrains ticks to be inside the specified range if clip=TRUE #' accepts nint=NULL as if it were missing z <- if(is.null(nint)) axisTicks(usr=usr, log=log, ...) else axisTicks(usr=usr, log=log, nint=nint, ...) if(clip) { zlimits <- if(log) 10^usr else usr z <- z[inside.range(z, zlimits)] } return(unique(z)) } numericalRange <- function(x, zlim=NULL) { xr <- suppressWarnings(range(x, finite=TRUE)) if(!all(is.finite(xr))) warning("All pixel values are NA", call.=FALSE) if(!is.null(zlim)) xr <- suppressWarnings(range(xr, zlim, finite=TRUE)) if(!all(is.finite(xr))) { warning("Cannot determine range of values for colour map", call.=FALSE) xr <- c(0,0) } return(xr) } # main function PlotIm <- function(x, ..., main, add=FALSE, clipwin=NULL, col=NULL, reverse.col=FALSE, valuesAreColours=NULL, log=FALSE, ncolours=256, gamma=1, ribbon=show.all, show.all=!add, drop.ribbon=FALSE, ribside=c("right", "left", "bottom", "top"), ribsep=0.15, ribwid=0.05, ribn=1024, ribscale=1, ribargs=list(), riblab=NULL, colargs=list(), useRaster=NULL, workaround=FALSE, zap=1, do.plot=TRUE, addcontour=FALSE, contourargs=list()) { if(missing(main)) main <- short.deparse(substitute(x)) verifyclass(x, "im") if(x$type == "complex") { cl <- match.call() cl$x <- solist(Re=Re(x), Im=Im(x), Mod=Mod(x), Arg=Arg(x)) cl[[1]] <- as.name('plot') cl$main <- main out <- eval(cl, parent.frame()) return(invisible(out)) } ribside <- match.arg(ribside) col.given <- !is.null(col) dotargs <- list(...) stopifnot(is.list(ribargs)) user.ticks <- ribargs$at user.nint <- ribargs$nint user.ribbonlabels <- ribargs$labels if(!is.null(clipwin)) { x <- x[as.rectangle(clipwin)] if(!is.rectangle(clipwin)) x <- x[clipwin, drop=FALSE] } zlim <- dotargs$zlim x <- repair.image.xycoords(x) xtype <- x$type xbox <- as.rectangle(x) do.log <- identical(log, TRUE) if(do.log && !(x$type %in% c("real", "integer"))) stop(paste("Log transform is undefined for an image of type", sQuote(xtype))) # determine whether pixel values are to be treated as colours if(!is.null(valuesAreColours)) { # argument given - validate stopifnot(is.logical(valuesAreColours)) if(valuesAreColours) { ## pixel values must be factor or character if(!xtype %in% c("factor", "character")) { if(do.plot) warning(paste("Pixel values of type", sQuote(xtype), "are not interpretable as colours")) valuesAreColours <- FALSE } else if(col.given) { ## colour info provided: contradictory if(do.plot) warning(paste("Pixel values are taken to be colour values,", "because valuesAreColours=TRUE;", "the colour map (argument col) is ignored"), call.=FALSE) col <- NULL } if(do.log && do.plot) warning(paste("Pixel values are taken to be colour values,", "because valuesAreColours=TRUE;", "the argument log=TRUE is ignored"), call.=FALSE) } } else if(col.given) { # argument 'col' controls colours valuesAreColours <- FALSE } else if(spatstat.options("monochrome")) { valuesAreColours <- FALSE } else { ## default : determine whether pixel values are colours strings <- switch(xtype, character = { as.vector(x$v) }, factor = { levels(x) }, { NULL }) valuesAreColours <- is.character(strings) && !inherits(try(col2rgb(strings), silent=TRUE), "try-error") if(valuesAreColours && do.plot) splat("Interpreting pixel values as colours", "(valuesAreColours=TRUE)") } # if(valuesAreColours) { # colour-valued images are plotted using the code for factor images # with the colour map equal to the levels of the factor switch(xtype, factor = { col <- levels(x) }, character = { x <- eval.im(factor(x)) xtype <- "factor" col <- levels(x) }, { if(do.plot) warning(paste("Pixel values of type", sQuote(xtype), "are not interpretable as colours")) }) # colours not suitable for ribbon ribbon <- FALSE } # transform pixel values to log scale? if(do.log) { rx <- range(x, finite=TRUE) if(all(rx > 0)) { x <- eval.im(log10(x)) } else { if(do.plot && any(rx < 0)) warning(paste("Negative pixel values", "omitted from logarithmic colour map;", "range of values =", prange(rx)), call.=FALSE) if(do.plot && !all(rx < 0)) warning("Zero pixel values omitted from logarithmic colour map", call.=FALSE) x <- eval.im(log10orNA(x)) } xtype <- x$type Log <- log10 Exp <- function(x) { 10^x } } else { Log <- Exp <- function(x) { x } } imagebreaks <- NULL # ribbonvalues <- ribbonbreaks <- NULL ribbonvalues <- NULL ## NOW DETERMINE THE COLOUR MAP colfun <- colmap <- NULL if(valuesAreColours) { ## pixel values are colours; set of colours was determined earlier colmap <- colourmap(col=col, inputs=col) } else if(!col.given) { ## no colour information given: use default colfun <- spatstat.options("image.colfun") } else if(inherits(col, "colourmap")) { ## Bob's your uncle colmap <- col } else if(is.function(col)) { ## Some kind of function determining a colour map if(names(formals(col))[1] == "n") { ## function(n) -> colour values colfun <- col } else { ## colour map determined by a rule (e.g. 'beachcolours') colmap <- invokeColourmapRule(col, x, zlim=zlim, colargs=colargs) if(is.null(colmap)) stop("Unrecognised syntax for colour function") } } switch(xtype, real = { vrange <- numericalRange(x, zlim) if(!is.null(colmap)) { # explicit colour map s <- summary(colmap) if(s$discrete) stop("Discrete colour map is not applicable to real values") imagebreaks <- s$breaks vrange <- range(imagebreaks) col <- s$outputs } trivial <- (diff(vrange) <= zap * .Machine$double.eps) #' ribbonvalues: a sequence of pixel values, mapped to colours #' ribbonrange: (min, max) of pixel values mapped by ribbon #' nominalrange: range of (scaled) values shown on ribbon #' nominalmarks: (scaled) values shown on ribbon at tick marks #' ribbonticks: pixel values corresponding to tick marks #' ribbonlabels: text displayed at tick marks if(trivial) { ribbonvalues <- mean(vrange) nominalmarks <- Log(ribscale * Exp(ribbonvalues)) } else { ribbonvalues <- seq(from=vrange[1L], to=vrange[2L], length.out=ribn) ribbonrange <- vrange nominalrange <- Log(ribscale * Exp(ribbonrange)) nominalmarks <- user.ticks %orifnull% Ticks(nominalrange, log=do.log, nint=user.nint) } ribbonticks <- Log(nominalmarks/ribscale) ribbonlabels <- user.ribbonlabels %orifnull% paste(nominalmarks) }, integer = { vrange <- numericalRange(x, zlim) trivial <- (diff(vrange) < 1) nominalrange <- Log(ribscale * Exp(vrange)) if(!is.null(user.ticks)) { nominalmarks <- user.ticks } else { nominalmarks <- Ticks(nominalrange, log=do.log, nint = user.nint) nominalmarks <- nominalmarks[nominalmarks %% 1 == 0] } ribbonticks <- Log(nominalmarks/ribscale) ribbonlabels <- user.ribbonlabels %orifnull% paste(nominalmarks) if(!do.log && isTRUE(all.equal(ribbonticks, vrange[1]:vrange[2]))) { #' each possible pixel value will appear in ribbon ribbonvalues <- vrange[1]:vrange[2] imagebreaks <- c(ribbonvalues - 0.5, vrange[2] + 0.5) ribbonrange <- range(imagebreaks) ribbonticks <- ribbonvalues ribbonlabels <- user.ribbonlabels %orifnull% paste(ribbonticks * ribscale) } else { ## not all possible values will appear in ribbon ribn <- min(ribn, diff(vrange)+1) ribbonvalues <- seq(from=vrange[1], to=vrange[2], length.out=ribn) ribbonrange <- vrange } if(!is.null(colmap)) { # explicit colour map s <- summary(colmap) imagebreaks <- if(!s$discrete) s$breaks else c(s$inputs[1] - 0.5, s$inputs + 0.5) col <- s$outputs } }, logical = { vrange <- c(0,1) trivial <- FALSE imagebreaks <- c(-0.5, 0.5, 1.5) ribbonvalues <- c(0,1) ribbonrange <- range(imagebreaks) # ribbonbreaks <- imagebreaks ribbonticks <- user.ticks %orifnull% ribbonvalues ribbonlabels <- user.ribbonlabels %orifnull% c("FALSE", "TRUE") if(!is.null(colmap)) col <- colmap(c(FALSE,TRUE)) }, factor = { lev <- levels(x) nvalues <- length(lev) trivial <- (nvalues < 2) # ensure all factor levels plotted separately fac <- factor(lev, levels=lev) intlev <- as.integer(fac) imagebreaks <- c(intlev - 0.5, max(intlev) + 0.5) ribbonvalues <- intlev ribbonrange <- range(imagebreaks) # ribbonbreaks <- imagebreaks ribbonticks <- user.ticks %orifnull% ribbonvalues ribbonlabels <- user.ribbonlabels %orifnull% paste(lev) vrange <- range(intlev) if(!is.null(colmap) && !valuesAreColours) col <- colmap(fac) }, character = { x <- eval.im(factor(x)) lev <- levels(x) nvalues <- length(lev) trivial <- (nvalues < 2) # ensure all factor levels plotted separately fac <- factor(lev, levels=lev) intlev <- as.integer(fac) imagebreaks <- c(intlev - 0.5, max(intlev) + 0.5) ribbonvalues <- intlev ribbonrange <- range(imagebreaks) # ribbonbreaks <- imagebreaks ribbonticks <- user.ticks %orifnull% ribbonvalues ribbonlabels <- user.ribbonlabels %orifnull% paste(lev) vrange <- range(intlev) if(!is.null(colmap)) col <- colmap(fac) }, stop(paste("Do not know how to plot image of type", sQuote(xtype))) ) ## Compute colour values to be passed to image.default if(!is.null(colmap)) { ## Explicit colour map object colourinfo <- list(breaks=imagebreaks, col=col) } else if(!is.null(colfun)) { ## Function colfun(n) if(trivial) ncolours <- 1 colourinfo <- if(is.null(imagebreaks)) list(col=colfun(ncolours)) else list(breaks=imagebreaks, col=colfun(length(imagebreaks) - 1L)) } else if(col.given) { ## Colour values if(inherits(try(col2rgb(col), silent=TRUE), "try-error")) stop("Unable to interpret argument col as colour values") if(is.null(imagebreaks)) { colourinfo <- list(col=col) } else { nintervals <- length(imagebreaks) - 1 colourinfo <- list(breaks=imagebreaks, col=col) if(length(col) != nintervals) stop(paste("Length of argument", dQuote("col"), paren(paste(length(col))), "does not match the number of distinct values", paren(paste(nintervals)))) } } else stop("Internal error: unable to determine colour values") if(spatstat.options("monochrome")) { ## transform to grey scale colourinfo$col <- to.grey(colourinfo$col) } if(isTRUE(reverse.col) && !valuesAreColours) { ## reverse the colour sequence (using rev.colourmap or rev.default) colourinfo$col <- rev(colourinfo$col) } # colour map to be returned (invisibly) i.col <- colourinfo$col i.bks <- colourinfo$breaks output.colmap <- if(is.null(i.col)) NULL else if(inherits(i.col, "colourmap")) i.col else if(valuesAreColours) colourmap(col=i.col, inputs=i.col) else switch(xtype, integer=, real= { if(!is.null(i.bks)) { colourmap(col=i.col, breaks=i.bks) } else colourmap(col=i.col, range=vrange, gamma=gamma) }, logical={ colourmap(col=i.col, inputs=c(FALSE,TRUE)) }, character=, factor={ colourmap(col=i.col, inputs=lev) }, NULL) ## gamma correction soc <- summary(output.colmap) if(!is.null(gamma <- soc$gamma) && gamma != 1) colourinfo$breaks <- soc$breaks ## ........ decide whether to use rasterImage ......... if(!isFALSE(useRaster)) { ## get device capabilities ## (this will start a graphics device if none is active) rasterable <- safeDevCapabilities()$rasterImage if(is.null(rasterable)) rasterable <- "no" ## can.use.raster <- switch(rasterable, yes=TRUE, no=FALSE, "non-missing"=!anyNA(x$v), FALSE) if(is.null(useRaster)) { useRaster <- can.use.raster } else if(useRaster && !can.use.raster) { whinge <- "useRaster=TRUE is not supported by the graphics device" if(rasterable == "non-missing") whinge <- paste(whinge, "for images with NA values") warning(whinge, call.=FALSE) } } ## ........ catch old usage (undocumented ) ................ contourargs <- resolve.defaults(contourargs, dotargs$args.contour) ## ........ start plotting ................. if(!isTRUE(ribbon) || (trivial && isTRUE(drop.ribbon))) { ## no ribbon wanted attr(output.colmap, "bbox") <- as.rectangle(x) if(!do.plot) return(output.colmap) ## plot image without ribbon image.doit(imagedata=list(x=cellbreaks(x$xcol, x$xstep), y=cellbreaks(x$yrow, x$ystep), z=t(x$v)), ## formal arguments add=add, show.all=show.all, W=xbox, addcontour=addcontour, contourargs=contourargs, workaround=workaround, ## argument lists list(axes=FALSE, xlab="",ylab=""), dotargs, list(useRaster=useRaster), colourinfo, list(zlim=vrange, asp = 1, main = main), list(values.are.log=do.log)) ## if(add && show.all) ## fakemaintitle(x, main, dotargs) do.box.etc(Frame(x), add, dotargs) return(invisible(output.colmap)) } # determine plot region bb <- owinInternalRect(x$xrange, x$yrange) Width <- diff(bb$xrange) Height <- diff(bb$yrange) Size <- max(Width, Height) switch(ribside, right={ # ribbon to right of image bb.rib <- owinInternalRect(bb$xrange[2] + c(ribsep, ribsep+ribwid) * Size, bb$yrange) rib.iside <- 4 }, left={ # ribbon to left of image bb.rib <- owinInternalRect(bb$xrange[1] - c(ribsep+ribwid, ribsep) * Size, bb$yrange) rib.iside <- 2 }, top={ # ribbon above image bb.rib <- owinInternalRect(bb$xrange, bb$yrange[2] + c(ribsep, ribsep+ribwid) * Size) rib.iside <- 3 }, bottom={ # ribbon below image bb.rib <- owinInternalRect(bb$xrange, bb$yrange[1] - c(ribsep+ribwid, ribsep) * Size) rib.iside <- 1 }) bb.all <- boundingbox(bb.rib, bb) attr(output.colmap, "bbox") <- bb.all attr(output.colmap, "bbox.legend") <- bb.rib attr(output.colmap, "side.legend") <- rib.iside if(!do.plot) return(output.colmap) pt <- prepareTitle(main) if(!add) { ## establish coordinate system do.call.plotfun(plot.owin, resolve.defaults(list(x=quote(bb.all), type="n", main=pt$blank), dotargs), extrargs=graphicsPars("owin")) } if(show.all) { ## plot title centred over main image area 'bb' do.call.plotfun(plot.owin, resolve.defaults(list(x=quote(bb), type="n", main=main, add=TRUE, show.all=TRUE), dotargs), extrargs=graphicsPars("owin")) main <- "" } # plot image image.doit(imagedata=list(x=cellbreaks(x$xcol, x$xstep), y=cellbreaks(x$yrow, x$ystep), z=t(x$v)), ## formal arguments add=TRUE, show.all=show.all, W=xbox, addcontour=addcontour, contourargs=contourargs, workaround=workaround, ## argument lists list(axes=FALSE, xlab="", ylab=""), dotargs, list(useRaster=useRaster), colourinfo, list(zlim=vrange, asp = 1, main = main), list(values.are.log=do.log)) ## if(add && show.all) ## fakemaintitle(bb.all, main, ...) # box or axes for image do.box.etc(bb, add, dotargs) # plot ribbon image containing the range of image values rib.npixel <- length(ribbonvalues) + 1 switch(ribside, left=, right={ # vertical ribbon rib.xcoords <- bb.rib$xrange rib.ycoords <- seq(from=bb.rib$yrange[1], to=bb.rib$yrange[2], length.out=rib.npixel) rib.z <- matrix(ribbonvalues, ncol=1) rib.useRaster <- useRaster }, top=, bottom={ # horizontal ribbon rib.ycoords <- bb.rib$yrange rib.xcoords <- seq(from=bb.rib$xrange[1], to=bb.rib$xrange[2], length.out=rib.npixel) rib.z <- matrix(ribbonvalues, nrow=1) # bug workaround rib.useRaster <- FALSE }) image.doit(imagedata=list(x=rib.xcoords, y=rib.ycoords, z=t(rib.z)), ## formal arguments add=TRUE, show.all=show.all, W=bb.rib, addcontour=addcontour, contourargs=contourargs, workaround=workaround, ## argument lists ribargs, list(useRaster=rib.useRaster), list(main="", sub="", xlab="", ylab=""), dotargs, colourinfo, list(values.are.log=do.log)) # box around ribbon? resol <- resolve.defaults(ribargs, dotargs) if(!identical(resol$box, FALSE)) plot(as.owin(bb.rib), add=TRUE) # scale axis for ribbon image ribaxis <- !(identical(resol$axes, FALSE) || identical(resol$ann, FALSE)) if(ribaxis) { ribaxis.iside <- rib.iside ## check for user-supplied xlim, ylim with reverse order ll <- resolve.defaults(ribargs, dotargs, list(xlim=NULL, ylim=NULL)) xlimflip <- is.numeric(ll$xlim) && (diff(ll$xlim) < 0) ylimflip <- is.numeric(ll$ylim) && (diff(ll$ylim) < 0) if(xlimflip) ribaxis.iside <- c(1, 4, 3, 2)[ribaxis.iside] if(ylimflip) ribaxis.iside <- c(3, 2, 1, 4)[ribaxis.iside] ## axisargs <- list(side=ribaxis.iside, labels=ribbonlabels) switch(ribside, right={ if(trivial) { at <- mean(bb.rib$yrange) } else { scal <- diff(bb.rib$yrange)/diff(ribbonrange) at <- bb.rib$yrange[1] + scal * (ribbonticks - ribbonrange[1]) } axisargs <- append(axisargs, list(at=at)) posargs <- list(pos=bb.rib$xrange[2], yaxp=c(bb.rib$yrange, length(ribbonticks))) }, left={ if(trivial) { at <- mean(bb.rib$yrange) } else { scal <- diff(bb.rib$yrange)/diff(ribbonrange) at <- bb.rib$yrange[1] + scal * (ribbonticks - ribbonrange[1]) } axisargs <- append(axisargs, list(at=at)) posargs <- list(pos=bb.rib$xrange[1], yaxp=c(bb.rib$yrange, length(ribbonticks))) }, top={ if(trivial) { at <- mean(bb.rib$xrange) } else { scal <- diff(bb.rib$xrange)/diff(ribbonrange) at <- bb.rib$xrange[1] + scal * (ribbonticks - ribbonrange[1]) } axisargs <- append(axisargs, list(at=at)) posargs <- list(pos=bb.rib$yrange[2], xaxp=c(bb.rib$xrange, length(ribbonticks))) }, bottom={ if(trivial) { at <- mean(bb.rib$xrange) } else { scal <- diff(bb.rib$xrange)/diff(ribbonrange) at <- bb.rib$xrange[1] + scal * (ribbonticks - ribbonrange[1]) } axisargs <- append(axisargs, list(at=at)) posargs <- list(pos=bb.rib$yrange[1], xaxp=c(bb.rib$xrange, length(ribbonticks))) }) do.call.plotfun(graphics::axis, resolve.defaults(axisargs, ribargs, dotargs, posargs), extrargs=graphicsPars("axis")) } if(!is.null(riblab)) { riblabel <- if(is.list(riblab)) riblab else list(text=riblab) riblabel$side <- rib.iside do.call(mtext, riblabel) } # return(invisible(output.colmap)) } PlotIm }) invokeColourmapRule <- function(colfun, x, ..., zlim=NULL, colargs=list()) { ## utility for handling special functions that generate colour maps ## either ## function(... range) -> colourmap ## function(... inputs) -> colourmap stopifnot(is.im(x)) stopifnot(is.function(colfun)) colargnames <- names(formals(colfun)) ## Convert it to a 'colourmap' colmap <- NULL xtype <- x$type if(xtype %in% c("real", "integer") && "range" %in% colargnames) { ## function(range) -> colourmap vrange <- range(range(x, finite=TRUE), zlim) cvals <- try(do.call.matched(colfun, append(list(range=vrange), colargs)), silent=TRUE) if(!inherits(cvals, "try-error")) { colmap <- if(inherits(cvals, "colourmap")) cvals else if(is.character(cvals)) colourmap(cvals, range=vrange) else NULL } } else if(xtype != "real" && "inputs" %in% colargnames) { ## function(inputs) -> colourmap vpossible <- switch(xtype, logical = c(FALSE, TRUE), factor = levels(x), unique(as.matrix(x))) if(!is.null(vpossible) && length(vpossible) < 256) { cvals <- try(do.call.matched(colfun, append(list(inputs=vpossible), colargs)), silent=TRUE) if(!inherits(cvals, "try-error")) { colmap <- if(inherits(cvals, "colourmap")) cvals else if(is.character(cvals)) colourmap(cvals, inputs=vpossible) else NULL } } } return(colmap) } ######################################################################## image.im <- plot.im ###################################################################### contour.im <- function (x, ..., main, axes=FALSE, add=FALSE, nlevels=10, levels=NULL, labels=NULL, log=FALSE, col=par("fg"), clipwin=NULL, show.all=!add, do.plot=TRUE) { defaultmain <- if(missing(main)) short.deparse(substitute(x)) else NULL dotargs <- list(...) bb <- Frame(x) xtype <- x$type ## contour spacing do.log <- isTRUE(log) if(do.log && !(xtype %in% c("real", "integer"))) stop(paste("Log transform is undefined for an image of type", sQuote(xtype))) ## return value result <- bb attr(result, "bbox") <- bb if(!do.plot) return(result) ## main title sop <- spatstat.options("par.contour") if(missing(main)) main <- resolve.1.default(list(main=defaultmain), sop) pt <- prepareTitle(main) ## plotting parameters if(missing(add)) { force(add) ## use default in formal arguments, unless overridden add <- resolve.1.default(list(add=add), sop) } if(missing(axes)) { force(axes) axes <- resolve.1.default(list(axes=axes), sop) } axes <- axes && !add col0 <- if(inherits(col, "colourmap")) par("fg") else col ## clip to subset if(!is.null(clipwin)) x <- x[clipwin, drop=FALSE] #' start plotting if(!add) { ## new plot - establish coordinate system if(axes && show.all) { #' standard plot initialisation in base graphics do.call.plotfun(plot.default, resolve.defaults( list(x = range(x$xcol), y = range(x$yrow), type = "n"), list(...), list(asp = 1, xlab = "x", ylab = "y", col = col0, main = main))) } else { #' plot invisible bounding box do.call.plotfun(plot.owin, resolve.defaults(list(x=quote(bb), type="n", main=pt$blank), dotargs), extrargs=graphicsPars("owin")) } } if(show.all && !axes) { ## plot title centred over contour region do.call.plotfun(plot.owin, resolve.defaults(list(x=quote(bb), main=main, add=TRUE, show.all=TRUE), dotargs, list(col.main=col0)), extrargs=graphicsPars("owin")) } ## Determine contour levels if(!do.log) { ## even spacing contourargs <- list(nlevels=nlevels, levels=levels, labels=labels) } else { ## logarithmic spacing rx <- range(x, finite=TRUE) ## take logarithm of pixel data if(all(rx > 0)) { x <- eval.im(log10(x)) } else { if(do.plot && any(rx < 0)) warning(paste("Negative pixel values", "omitted from logarithmic colour map;", "range of values =", prange(rx)), call.=FALSE) if(do.plot && !all(rx < 0)) warning("Zero pixel values omitted from logarithmic colour map", call.=FALSE) x <- eval.im(log10orNA(x)) } ## determine levels if(!is.null(levels)) { levels <- log10(levels) if(is.null(labels)) labels <- paste(levels) } else { logra <- range(x, finite=TRUE) ## default levels commensurate with logarithmic colour scale if(diff(logra) > 1.5 && missing(nlevels)) { wholepowers <- 10^(floor(logra[1]):ceiling(logra[2])) explevels <- sort(as.numeric(outer(wholepowers, c(1,2,5), "*"))) } else { explevels <- pretty(10^logra, nlevels) } explevels <- explevels[inside.range(explevels, 10^logra)] levels <- log10(explevels) if(is.null(labels)) labels <- paste(explevels) } contourargs <- list(levels=levels, labels=labels) } #' plot contour lines xcol <- x$xcol yrow <- x$yrow zmat <- t(x$v) dont.complain.about(xcol, yrow, zmat) if(!inherits(col, "colourmap")) { do.call.plotfun(contour.default, resolve.defaults(list(x=quote(xcol), y=quote(yrow), z=quote(zmat), add=TRUE, col=col), contourargs, list(...), .MatchNull=FALSE, .StripNULL=TRUE)) } else { clin <- do.call.matched(contourLines, resolve.defaults(list(x=quote(xcol), y=quote(yrow), z=quote(zmat)), contourargs, list(...), .MatchNull=FALSE, .StripNULL=TRUE)) linpar <- graphicsPars("lines") for(i in seq_along(clin)) { lini <- clin[[i]] levi <- lini$level coli <- col(levi) argi <- resolve.defaults(lini[c("x", "y")], list(...), list(col=coli)) do.call.matched(lines.default, argi, extrargs=linpar) } } return(invisible(result)) } ## not exported: log10orNA <- function(x) { y <- rep(NA_real_, length(x)) ok <- !is.na(x) & (x > 0) y[ok] <- log10(x[ok]) return(y) } spatstat.geom/R/terse.R0000644000176200001440000000251414611065352014516 0ustar liggesusers## terse.R ## ## code to control terseness and layout of printed output ## ## $Revision: 1.12 $ $Date: 2022/01/04 05:30:06 $ ## ## paragraph break in long output e.g. ppm parbreak <- function(terse = spatstat.options("terse")) { if(waxlyrical('space', terse)) cat("\n") return(invisible(NULL)) } waxlyrical <- local({ ## Values of spatstat.options('terse'): ## 0 default ## 1 suppress obvious wastage e.g. 'gory details' ## 2 contract space between paragraphs in long output ## 3 suppress extras e.g. standard errors and CI ## 4 suppress error messages eg failed to converge TerseCutoff <- list(gory=1, space=2, extras=3, errors=4) waxlyrical <- function(type, terse = spatstat.options("terse")) { if(!(type %in% names(TerseCutoff))) stop(paste("Internal error: unrecognised permission request", sQuote(type)), call.=TRUE) return(terse < TerseCutoff[[type]]) } waxlyrical }) ruletextline <- function(ch="-", n=getOption('width'), terse=spatstat.options('terse')) { if(waxlyrical('space', terse)) { chn <- paste(rep(ch, n), collapse="") chn <- substr(chn, 1, n) cat(chn, fill=TRUE) } return(invisible(NULL)) } spatstat.geom/NEWS0000644000176200001440000010022614766135011013547 0ustar liggesusers CHANGES IN spatstat.geom VERSION 3.3-6 OVERVIEW o We thank Warick Brown, Tilman Davies and Martin Hazelton for contributions. o Methods for functions which are constant on each tile of a tessellation. o Minor improvements. NEW FUNCTIONS o integral.tessfun Integral of a function which is constant on each tile of a tessellation o print.tessfun, plot.tessfun, as.tess.tessfun Methods for the class 'tessfun' of functions which are constant on each tile of a tessellation. SIGNIFICANT USER-VISIBLE CHANGES o plot.yardstick New argument 'style' allows different styles of plotting a scale bar including a zebra pattern (style = "zebra"). o plot.yardstick New arguments 'zebra.step', 'zebra.width', 'zebra.col'. o as.mask Corrected a warning message. CHANGES IN spatstat.geom VERSION 3.3-5 OVERVIEW o We thank Stephanie Hogg and Tingting Zhan for contributions. o Improvements to plotting of images, and arrays of images. o More control over plotting of colour maps, symbol maps and texture maps. o hyperframes handle a 'Surv' object as a single column. o Bug fixes and minor improvements. NEW FUNCTIONS o rev.colourmap Reverses the sequence of colour values in a colour map. A method for the generic 'rev'. SIGNIFICANT USER-VISIBLE CHANGES o hyperframe An object of class 'Surv' from the 'survival' package is now treated as a single column of data (mimicking the behaviour of 'data.frame') [Requested by Tingting Zhan] o plot.im New argument 'drop.ribbon' determines whether a ribbon will be displayed in the case where the pixel values are all equal. Default behaviour has changed. o plot.im New argument 'reverse.col' allows the sequence of colours to be reversed. [Suggested by Stephanie Hogg.] o plot.imlist, image.imlist, image.listof If equal.ribbon=TRUE and equal.scales=TRUE, the colour ribbon is now neatly aligned with the plotted images. o plot.solist, plot.anylist Arguments 'adorn.left', 'adorn.right', 'adorn.bottom', 'adorn.top' may now be objects of class 'colourmap' or 'symbolmap'. o plot.solist, plot.anylist New argument 'adorn.args'. o plot.imlist, image.imlist, image.listof New argument 'equal.scales'. o plot.colourmap New formal argument 'side'. o plot.symbolmap New formal argument 'side'. o plot.texturemap New formal argument 'side'. o persp.im Now recognises argument 'adj.main' controlling the position of main title. o persp.ppp Now recognises argument 'adj.main' controlling the position of main title. BUG FIXES o rotate.im Did not preserve the name of the unit of length. [Spotted by Stephanie Hogg.] Fixed. o unstack.ppp If 'marks(x)' was a data frame with a single column, the data frame structure was retained, when it should have been dropped. [Spotted by Tingting Zhan.] Fixed. CHANGES IN spatstat.geom VERSION 3.3-4 OVERVIEW o Tessellations can have any kind of marks. o More control over default colours. o Minor improvements. NEW FUNCTIONS o default.image.colours, reset.default.image.colours Control the default colours used for plotting images in spatstat. SIGNIFICANT USER-VISIBLE CHANGES o tess, marks<-.tess A tessellation can now have any kind of marks (vector, list, data frame or hyperframe). o intersect.tess Now handles marks of any kind (vector, list, data frame or hyperframe). o pixelquad Now accepts arguments passed to 'as.mask' to control the pixel resolution. o persp.ppp Now draws a reference scale bar for the vertical scale, by default. New arguments 'legend', 'legendpos', 'leg.args', 'leg.col'. o persp.ppp Optionally draws a symbol at the top of each spike. New arguments 'type', 'point.args'. CHANGES IN spatstat.geom VERSION 3.3-3 OVERVIEW o Perspective plot of spatial point pattern with numerical marks. o Improvements to rjitter.ppp o Tweaks to documentation. NEW FUNCTIONS o persp.ppp For a spatial point pattern with numeric marks, generate a perspective plot in which each data point is shown as a vertical spike, with height proportional to the mark value. SIGNIFICANT USER-VISIBLE CHANGES o rjitter.ppp New argument 'adjust' allows the default radius to be adjusted. o rjitter.ppp The resulting point pattern now has attribute 'radius'. o rjitter.ppp If 'retry=TRUE', the resulting point pattern now has attribute 'tries' which reports the number of trials that were required. CHANGES IN spatstat.geom VERSION 3.3-2 OVERVIEW o Tweaks to documentation to satisfy the package checker. CHANGES IN spatstat.geom VERSION 3.3-1 OVERVIEW o Tweaks to documentation to satisfy the package checker. CHANGES IN spatstat.geom VERSION 3.3-0 OVERVIEW o 'spatstat.geom' now depends on the new package 'spatstat.univar'. o Some functions have been moved into the package 'spatstat.univar'. o Tweaked plot functions. o More support for diagram objects. o Stability improvements and bug fixes. PACKAGE DEPENDENCE o spatstat.geom 'spatstat.geom' now depends on the new package 'spatstat.univar'. Several functions that were previously provided in 'spatstat.geom' have been moved to 'spatstat.univar'. NEW FUNCTIONS o default.symbolmap.ppp The algorithm for determining the graphical symbol map used by plot.ppp. o default.symbolmap New generic. o affine.diagramobj, reflect.diagramobj, rotate.diagramobj Methods for geometrical transformations of diagram objects. SIGNIFICANT USER-VISIBLE CHANGES o identify.ppp Automatically starts a new plot device and displays `x` if there is no plot device open. o identify.psp Identified segments are highlighted. Automatically starts a new plot device and displays `x` if there is no plot device open. o plot.owin New argument 'adj.main' controls the justification of the text in the main title. o plot.colourmap New argument 'nticks' controls the number of axis tick marks when the colourmap is defined on a continuous range of numerical values. o plot.colourmap New argument 'box' controls whether a box will be drawn around the colours. o plot.tess Changed the default values for do.col and do.labels o layout.boxes Argument 'aspect' can be NA or Inf indicating that the aspect ratio of the boxes is unconstrained. o simplepanel Improved stability. o shift Improved stability o as.colourmap.symbolmap A warning message, occurring when the symbolmap contains more than one colour map, is suppressed if the colour maps are identical. o plot.symbolmap Suppressed warning message (occurring when colour.only=TRUE) about the symbolmap containing several colour maps, when the colour maps were identical. DELETED FUNCTIONS o ewcdf This function has been moved to the new package 'spatstat.univar' along with most of the methods for class 'ewcdf'. o mean.ewcdf, quantile.ewcdf, quantilefun.ewcdf These methods have been moved to the new package 'spatstat.univar'. o hotrod This function has been moved to the new package 'spatstat.univar'. o integral The generic 'integral' and the method 'integral.density' have been moved to the new package 'spatstat.univar'. o quantilefun, quantilefun.ewcdf The generic 'quantilefun' and the method 'quantile.ewcdf' have been moved to the new package 'spatstat.univar'. o rounding, rounding.default The generic 'rounding' and the method 'rounding.default' have been moved to the new package 'spatstat.univar'. o transformquantiles This function has been moved to the new package 'spatstat.univar'. o weighted.median This function has been moved to the new package 'spatstat.univar'. o whist This function has been moved to the new package 'spatstat.univar'. o uniquemap, uniquemap.default, uniquemap.data.frame, uniquemap.matrix The generic 'uniquemap' and these methods have been moved to the new package 'spatstat.univar'. o unnormdensity This function has been moved to the new package 'spatstat.univar'. BUG FIXES o plot.ppp, default.symbolmap.ppp Ignored 'zerosize' in some cases. Fixed. o plot.symbolmap Issued strange warnings in some cases. Fixed. o symbolmap Crashed in some instances when 'inputs' was given and the graphical parameters included both functions and vectors. Fixed. CHANGES IN spatstat.geom VERSION 3.2-9 OVERVIEW o Some geometry code accelerated. NEW FUNCTIONS o summary.symbolmap, print.summary.symbolmap Method for 'summary' for symbol maps. SIGNIFICANT USER-VISIBLE CHANGES o as.rectangle Accelerated in many cases. o diameter.owin Accelerated when the window is a rectangle. o nncross.ppp Slightly accelerated. o owin Accelerated in many cases. CHANGES IN spatstat.geom VERSION 3.2-8 OVERVIEW o Improvements to window geometry code. o Improvements to symbol map displays. SIGNIFICANT USER-VISIBLE CHANGES o is.subset.owin Algorithm slightly modified to give better results when the two polygons share some common edges. o plot.ppp New argument 'minsize' specifies the size of the smallest symbol used to represent the marks, when the marks are numeric. o plot.ppp New argument 'zerosize' specifies the size of the symbol used to represent the mark value 0, when marks are numeric. o plot.symbolmap New argument 'representatives' specifies which data values will be shown in the plot. CHANGES IN spatstat.geom VERSION 3.2-7 OVERVIEW o Minor corrections to the help files. CHANGES IN spatstat.geom VERSION 3.2-6 OVERVIEW o Minor improvements. o spatstat.geom no longer suggests 'maptools'. SIGNIFICANT USER-VISIBLE CHANGES o as.im.tess New argument 'values'. CHANGES IN spatstat.geom VERSION 3.2-5 OVERVIEW o Extension of distance transform algorithm. o Improvement to progress reports. o Suppress annoying warnings. o Further bug fix in quadratcount SIGNIFICANT USER-VISIBLE CHANGES o distmap.owin New argument 'connect'. o progressreport The estimated time of completion is also printed, if the remaining time is longer than 10 minutes. o unnormdensity Suppress annoying warning messages from density.default. This affects many functions in the spatstat family of packages. BUG FIXES o quadratcount Crashed if argument 'tess' was a rectangular grid tessellation. Fixed. CHANGES IN spatstat.geom VERSION 3.2-4 OVERVIEW o Connected component transform can now use a 4-connected grid. o Bug fixes in quadrat counting code. SIGNIFICANT USER-VISIBLE CHANGES o connected.owin, connected.im New argument 'connect' specifies the connectivity of the raster, either 4 or 8 neighbours for each pixel. o round.ppp, round.pp3, round.ppx Now has ellipsis argument '...' for conformity with generic 'round' BUG FIXES o as.mask If 'w' was a rectangle and 'xy' was specified, the pixel entries were all TRUE, instead of only being TRUE within the window 'w'. Fixed. o intensity.quadratcount Results were incorrect if the quadrats were a mixture of irregular polygons and rectangles. o quadratcount.ppp If the window was irregular and some of the tiles did not intersect the window, the counts were given the wrong tile labels. Fixed. o plot.quadratcount If the window was irregular and some of the tiles did not intersect the window, the counts were displayed in the wrong tiles. Fixed. CHANGES IN spatstat.geom VERSION 3.2-2 OVERVIEW o Bug fixes and minor improvements. SIGNIFICANT USER-VISIBLE CHANGES o as.mask Improved numerical performance (rounding error). BUG FIXES o quantess.owin The window of the resulting tessellation was sometimes slightly different from the original window M. Fixed. o intensity.quadratcount Results were incorrect if the quadrats were the intersections of a rectangular grid with an irregular window and all quadrats were nonempty. Fixed. CHANGES IN spatstat.geom VERSION 3.2-1 OVERVIEW o Fixed errors and omissions in documentation. o Minor improvements in C code. CHANGES IN spatstat.geom VERSION 3.2-0 OVERVIEW o We thank Warick Brown and Tilman Davies for suggestions. o More options for converting polygons to a binary mask. o More options for controlling pixel size. o Improvement to progress reports. o Minor tweaks to package documentation. NEW FUNCTIONS o psp2mask Function 'as.mask.psp' has been renamed 'psp2mask'. The old function 'as.mask.psp' still exists, but it will soon be deprecated, and ultimately removed. SIGNIFICANT USER-VISIBLE CHANGES o owin2mask New options op="majority" and op="minority". If op="majority", a pixel belongs to the resulting mask if at least half of the pixel area is covered by the window. o as.mask New argument 'rule.eps' specifies what to do when the desired pixel size is not a divisor of the frame size. o as.im Many methods for 'as.im' now have argument 'rule.eps'. o discretise New argument 'rule.eps' o distfun New argument 'rule.eps' o nnfun New argument 'rule.eps' o progressreport New argument 'formula' controls the calculation of estimated time remaining. o progressreport New argument 'savehistory' specifies whether to save the elapsed times when the function was called. CHANGES IN spatstat.geom VERSION 3.1-0 OVERVIEW o Methods for "[[" and "[[<-" for hyperframes. o Colour map for pH values. o Restrict a colour map to a narrower range of values. o Integral of a one-dimensional density estimate. o Minor improvements and bug fixes. NEW FUNCTIONS o "[[.hyperframe", "[[<-.hyperframe" Methods for "[[" and "[[<-" for hyperframes. o pHcolourmap, pHcolour Colour map for values of pH o restrict.colourmap Restrict a colourmap to a narrower range of values. o integral.density Compute the integral of a one-dimensional kernel density estimate. o as.colourmap Extract colour information from an object. SIGNIFICANT USER-VISIBLE CHANGES o plot.symbolmap New argument colour.only makes it possible to display only the colour map information in a symbolmap. o "[.hyperframe", "[<-.hyperframe" Improved error message when the format of index i or j is not supported. o unnormdensity Computation accelerated. o unnormdensity Handles datasets containing fewer than 2 values. BUG FIXES o unnormdensity If 'weights' was a single numerical value 'w', the calculation incorrectly assigned the weight for each observation to be 'w/n' where 'n=length(x)'. Fixed. o unnormdensity A crash could occur if 'x' was a very long vector, with an error message originating from 'deparse1'. Fixed. CHANGES IN spatstat.geom VERSION 3.0-6 OVERVIEW o Bug fix. BUG FIXES o harmoniseLevels Crashed sometimes, in older versions of R, with an obscure error message from 'mapply'. Fixed. CHANGES IN spatstat.geom VERSION 3.0-5 OVERVIEW o Convert several factors or factor-valued images to a common set of levels. o Extension to rjitter o Alternative to rjitter o Quantile function as a function o Improvements to plot code. NEW FUNCTIONS o harmoniseLevels Given several factors or factor-valued pixel images, convert them all to have the same set of factor levels. o rexplode 'Explode' a point pattern by randomly displacing each group of duplicated points to make a circular pattern around the original location. An alternative to 'rjitter'. o quantilefun Return a function that computes any quantiles of a given dataset. SIGNIFICANT USER-VISIBLE CHANGES o rjitter.ppp If 'trim=TRUE', the displacement radius will be constrained to be less than or equal to the distance from the data point to the window boundary. o plot.ppp For multitype point patterns, a warning is issued if the plot legend does not represent every possible type of point due to space restrictions. o plot.symbolmap New argument 'warn'. o plot.symbolmap Issues a warning if the plot of a discrete symbol map does not represent every possible input value, due to space restrictions. o plot.solist When equal.ribbon=TRUE, the images may now be factor-valued or character-valued. Character-valued images will be converted to factor-valued images. The common colour map will combine the levels of all the factor images. BUG FIXES o "[<-.im" Errors occurred in x[] <- v when x and v were both factor-valued but with different sets of levels. o rjitter.ppp If retry=FALSE, marks were ignored. Fixed. CHANGES IN spatstat.geom VERSION 3.0-4 OVERVIEW o Improvements to perspective plots. SIGNIFICANT USER-VISIBLE CHANGES o perspPoints, perspLines, perspSegments, perspContour New argument 'occluded' specifies whether the surface should be treated as opaque or transparent. CHANGES IN spatstat.geom VERSION 3.0-3 OVERVIEW o Minor internal changes to satisfy package checker. CHANGES IN spatstat.geom VERSION 3.0-2 OVERVIEW o Minor internal changes to satisfy package checker. CHANGES IN spatstat.geom VERSION 3.0-1 OVERVIEW o Minor internal changes. CHANGES IN spatstat.geom VERSION 3.0-0 OVERVIEW o Minor improvements and bug fixes. o Changes to package dependence. NEW FUNCTIONS o is.linnet Test whether an object is a linear network. o as.data.frame.ppplist Method for 'as.data.frame' for lists of point patterns. SIGNIFICANT USER-VISIBLE CHANGES o Package dependence spatstat.geom now suggests the new packages spatstat.explore and spatstat.model, which have replaced spatstat.core. o crosspairs.ppp New argument 'periodic' specifies whether to use periodic (toroidal) distances. o crosspairs.ppp New arguments 'iX', 'iY' make it possible to eliminate pairs in which the two points are identical. o bufftess The result now has attribute 'breaks' which is the vector of distance breakpoints. o contour.im New argument 'log' specifies whether the contour lines should be equally spaced on a logarithmic scale. o plot.im, image.im New argument 'addcontour' specifies that contour lines should be drawn over the image plot. o invoke.symbolmap New argument 'angleref'. o funxy The result now has a unitname, inherited from the argument W. o integral.im New argument 'weight' specifies a weight function for the integration. o markstat, applynbd These functions now work for point patterns in three dimensions (class 'pp3') and point patterns on a network (class 'lpp'). o plot.psp New argument 'use.marks', for consistency with other methods. BUG FIXES o framedist.pixels Result was always a matrix, regardless of the value of 'style'. Fixed. o plot.im Ignored ribargs$labels. Fixed. o plot.ppp Crashed with an obscure message when argument 'shape' was given, unless argument 'size' was also given. Fixed. o closepairs Crashed if npoints(X)^2 exceeded the largest possible integer. Fixed. o crosspairs Crashed if npoints(X) * npoints(Y) exceeded the largest possible integer. Fixed. CHANGES IN spatstat.geom VERSION 2.4-0 OVERVIEW o We thank Fernando Milesi, Suman Rakshit and Mark Walsh for contributions. o Bug fixes in 'distmap' and 'distfun'. o Bug fixes in 'closepairs'. o Bug fixes in 'nncross.ppp'. o Minor improvements and bug fixes. NEW FUNCTIONS o framedist.pixels Computes distance from each pixel to the enclosing rectangle. SIGNIFICANT USER-VISIBLE CHANGES o nncross.ppp When X is a point pattern and Y is a line segment pattern, higher order neighbours (k > 1) are now supported. o intersect.tess New argument 'keepempty'. o unnormdensity Argument 'weights' may have length 1. New argument 'defaults'. o distmap.owin Behaviour has been altered so that, when X is a binary mask, the results of distmap(X, invert=TRUE) and distmap(complement.owin(X)) are identical. This affects a few pixels close to the edge of the frame. [Suggested by Fernando Milesi.] o distmap.ppp New argument 'clip'. BUG FIXES o distmap.owin If the window was a binary mask, the distance values were slightly too large (by a factor 1 + 1/n where n is the pixel grid dimension), due to a coding error. [Spotted by Fernando Milesi.] Fixed. o distfun.owin If the window was a binary mask, the distance values were slightly too small (typically reduced by 1/20 of a pixel width). [Spotted by Fernando Milesi.] Fixed. o distmap.owin Values were incorrect if X was an empty window (is.empty(X) = TRUE). Fixed. o distmap.ppp, distmap.psp Values were incorrect if X was an empty pattern (npoints(X) = 0). Fixed. o distmap.psp Values were incorrect if X was an empty pattern (nsegments(X) = 0). Fixed. o closepairs.ppp If distinct=FALSE and what="all", the resulting vectors 'yi' and 'yj' contained incorrect values, and had the wrong length. Fixed. o nncross.ppp When k > 1, distance values were incorrectly replaced by 'Inf' in some cases. Fixed. o closepairs.ppp Crashed with a message 'unable to allocate memory' if the window of X had zero area. Fixed. o crosspairs.ppp Crashed with a message 'unable to allocate memory' if the window of Y had zero area. Fixed. o closepairs.pp3 Crashed with a message 'unable to allocate memory' if the domain of X had zero volume. Fixed. o crosspairs.pp3 Crashed with a message 'unable to allocate memory' if the domain of Y had zero volume. Fixed. o as.im.owin If 'value' was a categorical (factor) value, the result was not a factor-valued image. Fixed. o tile.areas For a tessellation defined by a pixel image, the result of tile.areas() was not a numeric vector. [Spotted by Suman Rakshit.] Fixed. o dirichlet Rarely, the number of tiles in the tessellation was less than the number of unique data points. This occurred only when the window was a binary mask. [Spotted by Suman Rakshit.] Fixed. CHANGES IN spatstat.geom VERSION 2.3-2 OVERVIEW o 'spatstat.geom' now suggests the package 'spatstat.random'. o Updated help files to refer to 'spatstat.random'. CHANGES IN spatstat.geom VERSION 2.3-1 OVERVIEW o New options for weighted.quantile o Minor improvements. SIGNIFICANT USER-VISIBLE CHANGES o weighted.quantile New argument 'type' allows the user to choose between several rules for the weighted quantile. o weighted.median New argument 'type' allows the user to choose between several rules for the weighted median. The default rule has changed. o perspSegments Improved quality of result when pixels are not square. o nndist.ppp, nnwhich.ppp Argument 'by' can be a factor, a logical vector, a pixel image with factor values, a tessellation, a window, the string 'marks' (if marks(x) is a factor), or the name of one of the columns of marks (if marks(x) is a data frame). o nndist.pp3, nnwhich.pp3 Argument 'by' can be a factor, a logical vector, the string 'marks' (if marks(x) is a factor), or the name of one of the columns of marks (if marks(x) is a data frame). o split.ppp, split.ppx The argument 'f' may now be the character string "marks", signifying 'f=marks(X)', provided 'marks(X)' is a factor. o owin If argument 'mask' is a logical matrix, NA entries will be accepted, and converted to FALSE. CHANGES IN spatstat.geom VERSION 2.3-0 OVERVIEW o Quantile transformation. o Distance metric based on a convex set. o Basic support for calculations using non-Euclidean distance metrics. o Improvements to 'rjitter'. NEW CLASSES o metric An object of class 'metric' represents a distance metric. See help(metric.object). NEW FUNCTIONS o transformquantiles Transform the quantiles of a vector, matrix, array or pixel image. o convexmetric Distance metric based on a convex set. o mean.ecdf, mean.ewcdf Calculate the mean of an empirical cumulative distribution function. o invoke.metric Low level function to perform a desired operation using a given metric. o rjitter.ppp This function was previously called 'rjitter'. It is now a method for the new generic function 'rjitter'. SIGNIFICANT USER-VISIBLE CHANGES o pairdist.ppp, crossdist.ppp, nndist.ppp, nnwhich.ppp, nncross.ppp New argument 'metric' specifies a non-Euclidean distance metric to measure the distances. o distmap.ppp, distmap.owin, distmap.psp New argument 'metric' specifies a non-Euclidean distance metric to measure the distances. o disc New argument 'metric' specifies a non-Euclidean distance metric defining the disc. o rjitter The function previously called 'rjitter' is now called 'rjitter.ppp' and is now a method for the new generic 'rjitter'. o rjitter.ppp The argument 'radius' may be a numeric vector, specifying a different displacement radius for each data point. BUG FIXES o as.mask Crashed if 'Frame(w)' had zero height or zero width. Fixed. CHANGES IN spatstat.geom VERSION 2.2-2 OVERVIEW o Bug fix in package information. CHANGES IN spatstat.geom VERSION 2.2-1 OVERVIEW o More options for converting a window to a mask. o Minor improvements and internal upgrades. NEW FUNCTIONS o owin2mask Convert a window to a mask, with various options, affecting the treatment of the boundary. SIGNIFICANT USER-VISIBLE CHANGES o where.max, where.min Argument 'x' may be either a pixel image (class 'im') or data that can be converted to a pixel image by 'as.im'. CHANGES IN spatstat.geom VERSION 2.2-0 OVERVIEW o We thank Warick Brown for contributions. o Buffer tessellation o New options for distmap.psp NEW FUNCTIONS o bufftess Distance buffer tessellation SIGNIFICANT USER-VISIBLE CHANGES o distmap.psp New arguments 'extras' and 'clip' CHANGES IN spatstat.geom VERSION 2.1-0 OVERVIEW o We thank Hank Stevens for contributions. o Extension to 'discretise'. o Bug fix in nncross o Minor improvements and bug fixes SIGNIFICANT USER-VISIBLE CHANGES o discretise New argument 'move.points' determines whether the point coordinates are also discretised. o summary.im Output improved when the image is empty (i.e. when all pixel values are undefined). BUG FIXES o nncross.ppp If the argument 'by' was given, some of the results were incorrect. [Spotted by Hank Stevens.] Fixed. o nncross.ppp, nncross.pp3 If 'iX' and 'iY' were given, some of the results were incorrect. Fixed. CHANGES IN spatstat.geom VERSION 2.0-1 OVERVIEW o Minor bug fix BUG FIXES o pixellate.ppp crashed if 'weights' contained any NA values. Fixed. CHANGES IN spatstat.geom VERSION 2.0-0 OVERVIEW o Reduced package dependence. o Improvement to venn.tess. o Changed default value of 'stringsAsFactors'. SIGNIFICANT USER-VISIBLE CHANGES o spatstat.geom No longer depends on 'spatstat.sparse'. o venn.tess New argument 'labels'. o hyperframe, as.im.function The formal default value of 'stringsAsFactors' has been changed to 'NULL' to conform to changes in R. (The actual default value is TRUE for R < 4.1.0 and FALSE for R >= 4.1.0) o plot.psp The code for 'style="width"' has been completely rewritten, so that it no longer depends on plot.linim, and is more efficient. The formal argument list has been extended. o integral.im Accelerated in the case where 'domain' is a tessellation. o cbind.hyperframe Row names are not altered (previously they were altered using 'make.names') o [.ppx New argument 'clip' BUG FIXES o colourmap If a colour map was applied to numbers lying outside the range of the colour map, the wrong number of NA's was sometimes produced. Fixed. o MinkowskiSum Crashed sometimes with an error message about 'sumconnected'. Fixed. o hyperframe Crashed if the argument 'row.names' was given and the hyperframe had exactly one row. Fixed. CHANGES IN spatstat.geom VERSION 1.65-8 OVERVIEW o Reduced package dependence. SIGNIFICANT USER-VISIBLE CHANGES o spatstat.geom No longer depends on 'spatstat.sparse'. CHANGES IN spatstat.geom VERSION 1.65-7 OVERVIEW o Tweak. CHANGES IN spatstat.geom VERSION 1.65-6 OVERVIEW o We thank Jean-Francois Coeurjolly for contributions. o Bug fix in 'inradius' BUG FIXES o inradius Coded incorrectly for rectangular windows. [Spotted by Jean-Francois Coeurjolly] Fixed. CHANGES IN spatstat.geom VERSION 1.65-5 OVERVIEW o Minor changes to satisfy CRAN. CHANGES IN spatstat.geom VERSION 1.65-4 OVERVIEW o Minor changes to satisfy CRAN. CHANGES IN spatstat.geom VERSION 1.65-3 OVERVIEW o NEWS file initialised. CHANGES IN spatstat.geom VERSION 1.65-2 OVERVIEW o Minor changes to satisfy CRAN. CHANGES IN spatstat.geom VERSION 1.65-1 OVERVIEW o Minor changes to satisfy CRAN. CHANGES IN spatstat.geom VERSION 1.65-0 OVERVIEW o Package initialised at version 1.65-0 from a subset of spatstat. o Increased speed for large datasets. o Bug fix in crossdist.pp3 with periodic distances. o Bug fixes and minor improvements. SIGNIFICANT USER-VISIBLE CHANGES o spatstat.geom The package 'spatstat.geom' has been created from a subset of the code in the original 'spatstat' package version 1.65-0. It contains definitions of geometrical objects (windows, point patterns, pixel images, etc) and operations on them (geometry, superposition, image arithmetic, etc). o Execution The 'spatstat.geom' package is slightly faster than the corresponding code in the 'spatstat' package, because the procedure for calling internal C functions has been streamlined. o dirichletEdges New argument 'clip'. o harmonise.im The result belongs to class 'solist' and 'imlist' so that it can be plotted. BUG FIXES o crossdist.pp3 Results with periodic=TRUE were partially incorrect. Fixed. o affine.owin For mask windows, the pixel resolution of the result was too fine, leading to very large datasets. Fixed. o affine.im If the transformation matrix was not diagonal, the pixel resolution of the result was too fine, leading to very large datasets. Fixed. o plot.ppp For a point pattern in a binary mask window, if both arguments 'col' and 'cols' were given, the points were coloured according to 'col', which was incorrect. Fixed. o dirichletEdges Crashed if any edges crossed the boundary of the window. Fixed. o unitname Spatial datasets with incorrect internal format (or using an out-of-date version of the spatstat format) caused an error if the 'units' package was loaded. Fixed. spatstat.geom/src/0000755000176200001440000000000014611065354013637 5ustar liggesusersspatstat.geom/src/metricPdist.c0000644000176200001440000000461014611065353016272 0ustar liggesusers/* metricPdist.c Distance transform of binary pixel image using arbitrary metric This code #includes metricPdist.h multiple times. $Revision: 1.5 $ $Date: 2022/10/22 09:29:51 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ /* Once-only declarations: */ #include #include "raster.h" void dist_to_bdry(Raster *d); void shape_raster(Raster *ras, void *data, double xmin, double ymin, double xmax, double ymax, int nrow, int ncol, int mrow, int mcol); #define UNDEFINED -1 #define Is_Defined(I) (I >= 0) #define Is_Undefined(I) (I < 0) /* Definitions for each metric For each definition we need the following macros: FNAME Name of the function (that will be called from R) MARGLIST List of typed arguments to FNAME specifying the metric MTEMPDECLARE Declaration and initialisation of variables for use by metric METRIC Expression for calculating the metric (x1,y1,x2,y2) */ /* (1) Rectangular metric Unit ball is a rectangle with width 1 unit, height 'aspect' units. mdt = metric distance transform P = pixel image input O = orthogonally oriented to axis rect = rectangular */ #define FNAME mdtPOrect #define MARGLIST double *aspect #define MTEMPDECLARE double asp; asp=*aspect #define METRIC(X,Y,XX,YY) rectdist(X,Y,XX,YY,asp) double rectdist(double x, double y, double xx, double yy, double asp) { double dx, dy, d; dx = x-xx; dy = (y-yy)/asp; if(dx < 0) dx = -dx; if(dy < 0) dy = -dy; d = (dx > dy)? dx : dy; return d; } #include "metricPdist.h" #undef FNAME #undef MARGLIST #undef MARGDECLARE #undef MTEMPDECLARE #undef METRIC /* (2) Convex ball metric Unit ball is a symmetric convex polygon mdt = metric distance transform P = pixel image input conv = convex set */ #define FNAME mdtPconv #define MARGLIST int *ns, double *sx, double *sy #define MTEMPDECLARE int Ns; Ns=*ns; #define METRIC(X,Y,XX,YY) convdist(X,Y,XX,YY,Ns,sx,sy) double convdist( double x, double y, double xx, double yy, int Ns, double *sx, double *sy ) { int k; double dx, dy, dk, d; dx = x-xx; dy = y-yy; d = 0.0; for(k = 0; k < Ns; k++) { dk = dx * sx[k] + dy * sy[k]; if(dk > d) d = dk; } return d; } #include "metricPdist.h" #undef FNAME #undef MARGLIST #undef MARGDECLARE #undef MTEMPDECLARE #undef METRIC spatstat.geom/src/nngrid.h0000644000176200001440000000560414611065353015275 0ustar liggesusers #if (1 == 0) /* nngrid.h Code template for C functions nearest neighbour of each grid point THE FOLLOWING CODE ASSUMES THAT POINT PATTERN (xp, yp) IS SORTED IN ASCENDING ORDER OF x COORDINATE This code is #included multiple times in nngrid.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour Either or both DIST and WHICH may be defined. Copyright (C) Adrian Baddeley, Jens Oehlschlagel and Rolf Turner 2000-2013 Licence: GPL >= 2 $Revision: 1.5 $ $Date: 2022/10/22 02:32:10 $ */ #endif void FNAME( /* pixel grid dimensions */ int *nx, double *x0, double *xstep, int *ny, double *y0, double *ystep, /* data points */ int *np, double *xp, double *yp, /* outputs */ double *nnd, int *nnwhich, /* upper bound on pairwise distance */ double *huge ) { int Nxcol, Nyrow, Npoints; int i, j, ijpos; int mleft, mright, mwhich, lastmwhich; double X0, Y0, Xstep, Ystep; double d2, d2min, xj, yi, dx, dy, dx2, hu, hu2; Nxcol = *nx; Nyrow = *ny; Npoints = *np; hu = *huge; X0 = *x0; Y0 = *y0; Xstep = *xstep; Ystep = *ystep; hu2 = hu * hu; if(Npoints == 0) return; lastmwhich = 0; /* loop over pixels */ for(j = 0, xj = X0; j < Nxcol; j++, xj += Xstep) { R_CheckUserInterrupt(); for(i = 0, yi = Y0; i < Nyrow; i++, yi += Ystep) { /* reset nn distance and index */ d2min = hu2; mwhich = -1; if(lastmwhich < Npoints) { /* search forward from previous nearest neighbour */ for(mright = lastmwhich; mright < Npoints; ++mright) { dx = xp[mright] - xj; dx2 = dx * dx; if(dx2 > d2min) /* note that dx2 >= d2min could break too early */ break; dy = yp[mright] - yi; d2 = dy * dy + dx2; if (d2 < d2min) { /* save as nearest neighbour */ d2min = d2; mwhich = mright; } } /* end forward search */ } if(lastmwhich > 0) { /* search backward from previous nearest neighbour */ for(mleft = lastmwhich - 1; mleft >= 0; --mleft) { dx = xj - xp[mleft]; dx2 = dx * dx; if(dx2 > d2min) /* note that dx2 >= d2min could break too early */ break; dy = yp[mleft] - yi; d2 = dy * dy + dx2; if (d2 < d2min) { /* save as nearest neighbour */ d2min = d2; mwhich = mleft; } } /* end backward search */ } /* remember index of most recently-encountered neighbour */ lastmwhich = mwhich; /* copy nn distance for grid point (i, j) to output array nnd[i, j] */ ijpos = i + j * Nyrow; #ifdef DIST nnd[ijpos] = sqrt(d2min); #endif #ifdef WHICH nnwhich[ijpos] = mwhich + 1; /* R indexing */ #endif /* end of loop over grid points (i, j) */ } } } spatstat.geom/src/nn3DdistX.h0000644000176200001440000000637614611065353015641 0ustar liggesusers/* nn3DdistX.h Code template for nearest-neighbour algorithms for 3D point patterns Input is two point patterns - supports 'nncross' This code is #included multiple times in nn3Ddist.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour EXCLUDE #defined if the two patterns may include common points (which are not to be counted as neighbours) Either or both DIST and WHICH may be defined. THE FOLLOWING CODE ASSUMES THAT BOTH POINT PATTERNS ARE SORTED IN ASCENDING ORDER OF THE z COORDINATE If EXCLUDE is #defined, Code numbers id1, id2 are attached to the patterns X and Y respectively, such that x1[i], y1[i] and x2[j], y2[j] are the same point iff id1[i] = id2[j]. $Revision: 1.9 $ $Date: 2023/05/09 04:54:10 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #if (defined WHICH || !defined EXCLUDE) #define USEJWHICH #else #undef USEJWHICH #endif void FNAME( /* first point pattern */ int *n1, double *x1, double *y1, double *z1, int *id1, /* second point pattern */ int *n2, double *x2, double *y2, double *z2, int *id2, /* outputs */ double *nnd, /* n.n. distances */ int *nnwhich, /* n.d. identifiers */ /* prior upper bound on pairwise distances */ double *huge ) { int npoints1, npoints2, i, j, lastjwhich; double d2, d2min, x1i, y1i, z1i, dx, dy, dz, dz2, hu, hu2; #ifdef EXCLUDE int id1i; #endif #ifdef USEJWHICH int jwhich; #endif hu = *huge; hu2 = hu * hu; npoints1 = *n1; npoints2 = *n2; if(npoints1 == 0 || npoints2 == 0) return; lastjwhich = 0; /* remains unchanged if EXCLUDE is defined */ for(i = 0; i < npoints1; i++) { R_CheckUserInterrupt(); d2min = hu2; x1i = x1[i]; y1i = y1[i]; z1i = z1[i]; #ifdef EXCLUDE id1i = id1[i]; #endif #ifdef USEJWHICH jwhich = -1; #endif /* search backward from previous nearest neighbour */ if(lastjwhich > 0) { /* always true if EXCLUDE is defined */ for(j = lastjwhich - 1; j >= 0; --j) { dz = z2[j] - z1i; dz2 = dz * dz; if(dz2 > d2min) break; #ifdef EXCLUDE /* do not compare identical points */ if(id2[j] != id1i) { #endif dx = x2[j] - x1i; dy = y2[j] - y1i; d2 = dx * dx + dy * dy + dz2; if (d2 < d2min) { d2min = d2; #ifdef USEJWHICH jwhich = j; #endif } #ifdef EXCLUDE } #endif } } /* search forward from previous nearest neighbour */ if(lastjwhich < npoints2) { /* always false if EXCLUDE is defined */ for(j = lastjwhich; j < npoints2; ++j) { dz = z2[j] - z1i; dz2 = dz * dz; if(dz2 > d2min) break; #ifdef EXCLUDE /* do not compare identical points */ if(id2[j] != id1i) { #endif dx = x2[j] - x1i; dy = y2[j] - y1i; d2 = dx * dx + dy * dy + dz2; if (d2 < d2min) { d2min = d2; #ifdef USEJWHICH jwhich = j; #endif } #ifdef EXCLUDE } #endif } } #ifdef DIST nnd[i] = sqrt(d2min); #endif #ifdef WHICH /* convert to R indexing */ nnwhich[i] = jwhich + 1; #endif #ifndef EXCLUDE lastjwhich = jwhich; #endif } } #undef USEJWHICH spatstat.geom/src/knn3DdistX.h0000644000176200001440000001273214611065353016005 0ustar liggesusers #if (1 == 0) /* knn3DdistX.h Code template for C functions supporting nncross for k-nearest neighbours (k > 1) for 3D point patterns THE FOLLOWING CODE ASSUMES THAT LISTS ARE SORTED IN ASCENDING ORDER OF z COORDINATE This code is #included multiple times in nn3Ddist.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour EXCLUDE #defined if exclusion mechanism is used Either or both DIST and WHICH may be defined. When EXCLUDE is defined, code numbers id1, id2 are attached to the patterns X and Y respectively, such that X[i] and Y[j] are the same point iff id1[i] = id2[j]. Copyright (C) Adrian Baddeley, Jens Oehlschlagel and Rolf Turner 2000-2013 Licence: GPL >= 2 $Revision: 1.5 $ $Date: 2023/05/09 04:59:28 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #endif void FNAME( /* inputs */ int *n1, double *x1, double *y1, double *z1, int *id1, int *n2, double *x2, double *y2, double *z2, int *id2, int *kmax, /* output matrices (n1 * kmax) in ROW MAJOR order */ double *nnd, int *nnwhich, double *huge /* some inputs + outputs are not used in all functions */ ) { int npoints1, npoints2, nk, nk1; int maxchunk, i, jleft, jright, lastjwhich, unsorted, k, k1; double d2, d2minK, x1i, y1i, z1i, dx, dy, dz, dz2, hu, hu2, tmp; double *d2min; #ifdef WHICH int *which; int itmp; #endif #ifdef EXCLUDE int id1i; #else int jwhich; #endif npoints1 = *n1; npoints2 = *n2; nk = *kmax; nk1 = nk - 1; hu = *huge; hu2 = hu * hu; if(npoints1 == 0 || npoints2 == 0) return; lastjwhich = 0; /* remains unchanged if EXCLUDE is defined */ /* create space to store the nearest neighbour distances and indices for the current point */ d2min = (double *) R_alloc((size_t) nk, sizeof(double)); #ifdef WHICH which = (int *) R_alloc((size_t) nk, sizeof(int)); #endif /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < npoints1) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > npoints1) maxchunk = npoints1; for(; i < maxchunk; i++) { /* initialise nn distances and indices */ d2minK = hu2; #ifndef EXCLUDE jwhich = -1; #endif for(k = 0; k < nk; k++) { d2min[k] = hu2; #ifdef WHICH which[k] = -1; #endif } x1i = x1[i]; y1i = y1[i]; z1i = z1[i]; #ifdef EXCLUDE id1i = id1[i]; #endif if(lastjwhich < npoints2) { /* always true if EXCLUDE is defined */ /* search forward from previous nearest neighbour */ for(jright = lastjwhich; jright < npoints2; ++jright) { dz = z2[jright] - z1i; dz2 = dz * dz; if(dz2 > d2minK) /* note that dz2 >= d2minK could break too early */ break; #ifdef EXCLUDE /* do not compare identical points */ if(id2[jright] != id1i) { #endif dy = y2[jright] - y1i; d2 = dy * dy + dz2; if(d2 < d2minK) { dx = x2[jright] - x1i; d2 = dx * dx + d2; if (d2 < d2minK) { /* overwrite last entry in list of neighbours */ d2min[nk1] = d2; #ifndef EXCLUDE jwhich = jright; #endif #ifdef WHICH which[nk1] = jright; #endif /* bubble sort */ unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } /* adjust maximum distance */ d2minK = d2min[nk1]; } } #ifdef EXCLUDE } #endif } /* end forward search */ } if(lastjwhich > 0) { /* always false if EXCLUDE is defined */ /* search backward from previous nearest neighbour */ for(jleft = lastjwhich - 1; jleft >= 0; --jleft) { dz = z1i - z2[jleft]; dz2 = dz * dz; if(dz2 > d2minK) /* note that dz2 >= d2minK could break too early */ break; #ifdef EXCLUDE /* do not compare identical points */ if(id2[jleft] != id1i) { #endif dy = y2[jleft] - y1i; d2 = dy * dy + dz2; if(d2 < d2minK) { dx = x2[jleft] - x1i; d2 = dx * dx + d2; if (d2 < d2minK) { /* overwrite last entry in list of neighbours */ d2min[nk1] = d2; #ifndef EXCLUDE jwhich = jleft; #endif #ifdef WHICH which[nk1] = jleft; #endif /* bubble sort */ unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } /* adjust maximum distance */ d2minK = d2min[nk1]; } } #ifdef EXCLUDE } #endif } /* end backward search */ } /* copy nn distances for point i to output matrix in ROW MAJOR order */ for(k = 0; k < nk; k++) { #ifdef DIST nnd[nk * i + k] = sqrt(d2min[k]); #endif #ifdef WHICH nnwhich[nk * i + k] = which[k] + 1; /* R indexing */ #endif } #ifndef EXCLUDE /* save index of last neighbour encountered */ lastjwhich = jwhich; #endif /* end of loop over points i */ } } } spatstat.geom/src/connectpix.c0000644000176200001440000000346314611065353016162 0ustar liggesusers/* connectpix.c Connected component transforms for pixel image coco8int 8-connected, integer image coco4int 4-connected, integer image coco8dbl 8-connected, double precision image coco4dbl 4-connected, double precision image The input is a pixel image in which background pixels have value 0 and all non-background pixels have been initialised to different nonzero values. (Double precision images are needed when the raster is too large for every pixel to be labelled with a different integer.) This code repeatedly #includes 'connectpix.h' $Revision: 1.18 $ $Date: 2023/07/18 04:04:05 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2023 Licence: GNU Public Licence >= 2 */ #include #include #include #include #include "raster.h" #include "yesno.h" void shape_raster(Raster *ras, void *data, double xmin, double ymin, double xmax, double ymax, int nrow, int ncol, int mrow, int mcol); /* integer, 8-connected */ #define STYPE int #define CONN 8 #define INAME Iconcom8 #define RNAME coco8int #include "connectpix.h" #undef INAME #undef RNAME #undef CONN #undef STYPE /* integer, 4-connected */ #define STYPE int #define CONN 4 #define INAME Iconcom4 #define RNAME coco4int #include "connectpix.h" #undef INAME #undef RNAME #undef CONN #undef STYPE /* double, 8-connected */ #define STYPE double #define CONN 8 #define INAME Dconcom8 #define RNAME coco8dbl #include "connectpix.h" #undef INAME #undef RNAME #undef CONN #undef STYPE /* double, 4-connected */ #define STYPE double #define CONN 4 #define INAME Dconcom4 #define RNAME coco4dbl #include "connectpix.h" #undef INAME #undef RNAME #undef CONN #undef STYPE spatstat.geom/src/auctionbf.c0000644000176200001440000001572414611065353015765 0ustar liggesusers/* auctionbf.c $Revision: 1.1 $ $Date: 2014/06/28 02:14:04 $ Code by Dominic Schuhmacher up to local adaptations for spatstat this code is identical to Revision 0.4 for the R package transport */ /* n >= 2 is assumed throughout !!!!!!!!! */ #include #include #include typedef struct State { int n; double epsbid; /* the current eps */ int backwards; /* 0 if we should do forward auction, 1 if we should do backward auction */ int nofassigned; /* number of assigned persons */ int *pers_to_obj; /* -1 means unassigned */ int *obj_to_pers; /* -1 means unassigned */ double *price; double *profit; int *desiremat; /* matrix of desires */ double *persvalue; /* desire minus price of current person in forward phase */ double *objvalue; /* desire minus profit of current object in reverse phase */ /* last three only used in bid, but maybe better to reserve memory once and for all */ } State; #define DESIRE(I,J,STATE,NVALUE) ((STATE)->desiremat)[(NVALUE) * (J) + (I)] #define DESIREMAIN(I,J,STATE,NVALUE) ((STATE).desiremat)[(NVALUE) * (J) + (I)] #define MIN(A,B) ((A)<(B) ? (A) : (B)) void bidbf(State *state, int person); void lurebf(State *state, int obj); int arrayargmax(double *a, int n); double arraysec(double *a, int n, int arg); /* void printit(State *state); */ /* ------------ The main function ----------------------------- */ void auctionbf(int *desirem, int *nn, int *pers_to_obj, double *price, double *profit, int *kk, double *eps) { int i,j,r; /* indices */ int k,n; State state; /* inputs */ state.n = n = *nn; k = *kk; /* length of eps, only needed in outside loop */ state.pers_to_obj = pers_to_obj; /* n vector: person i gets which object */ state.price = price; /* n vector: price of object j */ state.profit = profit; /* n vector: profit of person i */ state.desiremat = desirem; /* n x n vector: desire of person i for object j */ /* scratch space */ state.obj_to_pers = (int *) R_alloc((long) n, sizeof(int)); state.persvalue = (double *) R_alloc((long) n, sizeof(double)); state.objvalue = (double *) R_alloc((long) n, sizeof(double)); /* Prices start at what the R-function supplied (usually 0) */ /* Profits are set to the rowwise max that satisfies eps-CS */ for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { state.persvalue[j] = DESIREMAIN(i,j,state,n); } state.profit[i] = arrayargmax(state.persvalue, n); } for (r = 0; r < k; r++) { state.backwards = 0; state.epsbid = eps[r]; /* At start everything is unassigned */ state.nofassigned = 0; for (j = 0; j < n; j++) { state.pers_to_obj[j] = -1; state.obj_to_pers[j] = -1; } while (state.nofassigned < n) { /* printit(&state); */ R_CheckUserInterrupt(); if (state.backwards == 0) { /* printit(&state); */ for (i = 0; i < n; i++) { if (state.pers_to_obj[i] == -1) { /* Rprintf("Bid \n"); */ bidbf(&state, i); /* bid does assigning and unassigning and changes nofassigned */ } } } else { /* printit(&state); */ for (j = 0; j < n; j++) { if (state.obj_to_pers[j] == -1) { /* Rprintf("Lure \n"); */ lurebf(&state, j); /* lure does assigning and unassigning and changes nofassigned */ } } } } /* eof while */ } /* eof eps-scaling for-loop */ } /* ------------ Functions called by auction ------------------------- */ void bidbf(State *state, int person) { int j; int n; int bidfor, oldpers; double bidamount; n = state->n; for (j = 0; j < n; j++) { state->persvalue[j] = DESIRE(person,j,state,n) - state->price[j]; } bidfor = arrayargmax(state->persvalue, n); bidamount = state->persvalue[bidfor] - arraysec(state->persvalue,n,bidfor) + state->epsbid; /* here we get a float result, the rest are int results */ oldpers = state->obj_to_pers[bidfor]; if (oldpers == -1) { state->nofassigned++; state->backwards = 1; } else { state->pers_to_obj[oldpers] = -1; } state->pers_to_obj[person] = bidfor; state->obj_to_pers[bidfor] = person; state->price[bidfor] = state->price[bidfor] + bidamount; /* new forward/reverse auction algo */ state->profit[person] = DESIRE(person,bidfor,state,n) - state->price[bidfor]; } /* like bidbf, but for reverse auction */ void lurebf(State *state, int obj) { int i; int n; int lurepno, oldobj; double lureamount; n = state->n; for (i = 0; i < n; i++) { state->objvalue[i] = DESIRE(i,obj,state,n) - state->profit[i]; } lurepno = arrayargmax(state->objvalue, n); lureamount = state->objvalue[lurepno] - arraysec(state->objvalue,n,lurepno) + state->epsbid; /* here we get a float result, the rest are int results */ oldobj = state->pers_to_obj[lurepno]; if (oldobj == -1) { state->nofassigned++; state->backwards = 0; } else { state->obj_to_pers[oldobj] = -1; } state->obj_to_pers[obj] = lurepno; state->pers_to_obj[lurepno] = obj; state->profit[lurepno] = state->profit[lurepno] + lureamount; /* new forward/reverse auction algo */ state->price[obj] = DESIRE(lurepno,obj,state,n) - state->profit[lurepno]; } /* ------------ Little helpers ------------------------- */ /* Gives first index that maximizes array */ int arrayargmax(double *a, int n) { int i, arg; double amax; arg = 0; amax = a[0]; for (i = 1; i < n; i++) if (a[i] > amax) { arg = i; amax = a[i]; } return(arg); } /* Second largest element of a non-negative integer array knowing the largest is at index arg */ double arraysec(double *a, int n, int arg) { int i; double amax; if (arg > 0) amax = a[0]; else amax = a[1]; for (i = 0; i < arg; i++) if (a[i] > amax) amax = a[i]; for (i = arg+1; i < n; i++) if (a[i] > amax) amax = a[i]; return(amax); } /* void printit(State *state) { int i=0,n=0; n = state->n; Rprintf("Current state: \n"); Rprintf("backwards: %d \n", state->backwards); Rprintf("nofassigned: %d \n", state->nofassigned); Rprintf("pers_to_obj: "); for (i = 0; i < n; i++) { Rprintf("%d ", state->pers_to_obj[i]); } Rprintf("\n"); Rprintf("obj_to_pers: "); for (i = 0; i < n; i++) { Rprintf("%d ", state->obj_to_pers[i]); } Rprintf("\n"); Rprintf("price: "); for (i = 0; i < n; i++) { Rprintf("%2.9lf ", state->price[i]); } Rprintf("\n"); Rprintf("profit: "); for (i = 0; i < n; i++) { Rprintf("%2.9lf ", state->profit[i]); } Rprintf("\n"); Rprintf("persvalue: "); for (i = 0; i < n; i++) { Rprintf("%2.9lf ", state->persvalue[i]); } Rprintf("\n"); Rprintf("objvalue: "); for (i = 0; i < n; i++) { Rprintf("%2.9lf ", state->objvalue[i]); } Rprintf("\n"); Rprintf("\n\n\n"); } */ spatstat.geom/src/hasclose.h0000644000176200001440000001573014611065353015616 0ustar liggesusers/* hasclose.h Function definitions to be #included in hasclose.c several times with different values of macros. Macros used: CLOSEFUN name of function for pairs in a single pattern CROSSFUN name of function for pairs between two patterns ZCOORD if defined, coordinates are 3-dimensional TORUS if defined, distances are periodic BUG debugger flag $Revision: 1.12 $ $Date: 2022/10/21 10:43:01 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ void CLOSEFUN( int *n, double *x, double *y, #ifdef ZCOORD double *z, #endif double *r, /* distance deemed 'close' */ #ifdef TORUS double *b, /* box dimensions */ #endif int *t /* result: true/false */ ) { double xi, yi, rmax, r2max, rmaxplus, dx, dy, d2minr2; #ifdef ZCOORD double zi, dz; #endif int N, maxchunk, i, j; #ifdef TORUS double Bx, By, Hy; #ifdef ZCOORD double Bz, Hz; #endif #endif N = *n; rmax = *r; r2max = rmax * rmax; rmaxplus = rmax + rmax/16.0; #ifdef TORUS Bx = b[0]; By = b[1]; Hy = By/2.0; #ifdef ZCOORD Bz = b[2]; Hz = Bz/2.0; #endif #endif /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < N) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > N) maxchunk = N; for(; i < maxchunk; i++) { xi = x[i]; yi = y[i]; #ifdef ZCOORD zi = z[i]; #endif if(i > 0) { /* scan backward from i */ for(j = i - 1; j >= 0; j--) { dx = xi - x[j]; if(dx > rmaxplus) break; dy = y[j] - yi; #ifdef TORUS if(dy < 0.0) dy = -dy; if(dy > Hy) dy = By - dy; #endif d2minr2 = dx * dx + dy * dy - r2max; #ifdef ZCOORD if(d2minr2 <= 0.0) { dz = z[j] - zi; #ifdef TORUS if(dz < 0.0) dz = -dz; if(dz > Hz) dz = Bz - dz; #endif d2minr2 = d2minr2 + dz * dz; #endif if(d2minr2 <= 0.0) { /* pair (i, j) is close */ t[i] = t[j] = 1; } #ifdef ZCOORD } #endif } #ifdef TORUS /* wrap-around */ /* scan forward from 0 */ for(j = 0; j < i; j++) { dx = Bx + x[j] - xi; if(dx > rmaxplus) break; dy = y[j] - yi; #ifdef TORUS if(dy < 0.0) dy = -dy; if(dy > Hy) dy = By - dy; #endif d2minr2 = dx * dx + dy * dy - r2max; #ifdef ZCOORD if(d2minr2 <= 0.0) { dz = z[j] - zi; #ifdef TORUS if(dz < 0.0) dz = -dz; if(dz > Hz) dz = Bz - dz; #endif d2minr2 = d2minr2 + dz * dz; #endif if(d2minr2 <= 0.0) { /* pair (i, j) is close */ t[i] = t[j] = 1; } #ifdef ZCOORD } #endif } #endif } } } } /* ........................................................ */ void CROSSFUN( int *n1, double *x1, double *y1, #ifdef ZCOORD double *z1, #endif int *n2, double *x2, double *y2, #ifdef ZCOORD double *z2, #endif double *r, #ifdef TORUS double *b, /* box dimensions (same for both patterns!!) */ #endif int *t ) { /* lengths */ int N1, N2, maxchunk; /* distance parameter */ double rmax, r2max, rmaxplus; /* indices */ int i, j, jleft; /* temporary values */ double x1i, y1i, xleft, dx, dy, dx2, d2minr2; #ifdef ZCOORD double z1i, dz; #endif #ifdef TORUS double Bx, By, Hx, Hy; int jright; #ifdef ZCOORD double Bz, Hz; #endif #endif N1 = *n1; N2 = *n2; rmax = *r; r2max = rmax * rmax; rmaxplus = rmax + rmax/16.0; #ifdef TORUS Bx = b[0]; By = b[1]; Hx = Bx/2.0; Hy = By/2.0; #ifdef BUG Rprintf("=> PERIODIC: Bx = %lf, By = %lf <= \n", Bx, By); #endif #ifdef ZCOORD Bz = b[2]; Hz = Bz/2.0; #endif #endif if(N1 > 0 && N2 > 0) { i = 0; maxchunk = 0; jleft = 0; while(i < N1) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > N1) maxchunk = N1; for( ; i < maxchunk; i++) { x1i = x1[i]; y1i = y1[i]; #ifdef ZCOORD z1i = z1[i]; #endif #ifdef BUG Rprintf("------ i = %d --------\n", i); Rprintf(" [%d] = (%lf, %lf)\n", i, x1i, y1i); #endif /* adjust starting point jleft */ xleft = x1i - rmaxplus; while((x2[jleft] < xleft) && (jleft+1 < N2)) ++jleft; #ifdef BUG Rprintf("\t jleft = %d\n", jleft); #endif /* process from j = jleft until dx > rmax + epsilon */ for(j=jleft; j < N2; j++) { dx = x2[j] - x1i; #ifdef BUG Rprintf("\t Central loop, j = %d, dx = %lf\n", j, dx); #endif if(dx > rmaxplus) break; dx2 = dx * dx; dy = y2[j] - y1i; #ifdef BUG Rprintf("\t\t Did not break\n\t\t dy = %lf\n", dy); #endif #ifdef TORUS if(dy < 0.0) dy = -dy; if(dy > Hy) dy = By - dy; #ifdef BUG Rprintf("\t\t periodic dy = %lf\n", dy); #endif #endif d2minr2 = dx2 + dy * dy - r2max; #ifdef ZCOORD if(d2minr2 <= 0.0) { dz = z2[j] - z1i; #ifdef TORUS if(dz < 0.0) dz = -dz; if(dz > Hz) dz = Bz - dz; #endif d2minr2 = d2minr2 + dz * dz; #endif if(d2minr2 <= 0.0) { #ifdef BUG Rprintf("\t\t Point %d has close neighbour\n", i); #endif /* point i has a close neighbour */ t[i] = 1; break; } #ifdef ZCOORD } #endif } #ifdef TORUS jright = j; /* wrap-around at start */ #ifdef BUG Rprintf("\t Wrap around at start for j = 0 to %d\n", jleft); #endif for(j=0; j < jleft; j++) { dx = x1i - x2[j]; #ifdef BUG Rprintf("\t\t j = %d, dx = %lf\n", j, dx); #endif if(dx < 0.0) dx = -dx; if(dx > Hx) dx = Bx - dx; #ifdef BUG Rprintf("\t\t periodic dx = %lf\n", dx); #endif if(dx > rmaxplus) break; dx2 = dx * dx; dy = y2[j] - y1i; #ifdef BUG Rprintf("\t\t Did not break\n\t\t dy = %lf\n", dy); #endif if(dy < 0.0) dy = -dy; if(dy > Hy) dy = By - dy; #ifdef BUG Rprintf("\t\t periodic dy = %lf\n", dy); #endif d2minr2 = dx2 + dy * dy - r2max; #ifdef ZCOORD if(d2minr2 <= 0.0) { dz = z2[j] - z1i; if(dz < 0.0) dz = -dz; if(dz > Hz) dz = Bz - dz; d2minr2 = d2minr2 + dz * dz; #endif if(d2minr2 <= 0.0) { /* point i has a close neighbour */ #ifdef BUG Rprintf("\t\t Point %d has close neighbour\n", i); #endif t[i] = 1; break; } #ifdef ZCOORD } #endif } /* wrap around at end */ #ifdef BUG Rprintf("\t Wrap around at end for j = %d to %d\n", N2-1, jright); #endif for(j=N2-1; j >= jright; j--) { dx = x1i - x2[j]; #ifdef BUG Rprintf("\t\t j = %d, dx = %lf\n", j, dx); #endif if(dx < 0.0) dx = -dx; if(dx > Hx) dx = Bx - dx; #ifdef BUG Rprintf("\t\t periodic dx = %lf\n", dx); #endif if(dx > rmaxplus) break; dx2 = dx * dx; dy = y2[j] - y1i; #ifdef BUG Rprintf("\t\t Did not break\n\t\t dy = %lf\n", dy); #endif if(dy < 0.0) dy = -dy; if(dy > Hy) dy = By - dy; #ifdef BUG Rprintf("\t\t periodic dy = %lf\n", dy); #endif d2minr2 = dx2 + dy * dy - r2max; #ifdef ZCOORD if(d2minr2 <= 0.0) { dz = z2[j] - z1i; if(dz < 0.0) dz = -dz; if(dz > Hz) dz = Bz - dz; d2minr2 = d2minr2 + dz * dz; #endif if(d2minr2 <= 0.0) { #ifdef BUG Rprintf("\t\t Point %d has close neighbour\n", i); #endif /* point i has a close neighbour */ t[i] = 1; break; } #ifdef ZCOORD } #endif } #endif } } } } spatstat.geom/src/closepair.c0000644000176200001440000002125314611065353015766 0ustar liggesusers/* closepair.c $Revision: 1.39 $ $Date: 2022/10/22 09:29:51 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Assumes point pattern is sorted in increasing order of x coordinate paircount() count the total number of pairs (i, j) with distance < rmax crosscount() count total number of close pairs in two patterns [To count number of neighbours for each point, see Cclosepaircounts, Ccrosspaircounts defined in Estrauss.c] duplicatedxy() find duplicated (x,y) pairs Fclosepairs() extract close pairs of coordinates .C interface - output vectors have Fixed length Fcrosspairs() extract close pairs in two patterns .C interface - output vectors have Fixed length Vclosepairs() extract close pairs of coordinates .Call interface - output vectors have Variable length Vcrosspairs() extract close pairs in two patterns .Call interface - output vectors have Variable length */ #include #include #include #define OK 0 #define ERR_OVERFLOW 1 #define ERR_ALLOC 2 #define FAILED(X) ((void *)(X) == (void *)NULL) #define intRealloc(PTR, OLDLENGTH, NEWLENGTH) \ (int *) S_realloc((char *) PTR, NEWLENGTH, OLDLENGTH, sizeof(int)) #define dblRealloc(PTR, OLDLENGTH, NEWLENGTH) \ (double *) S_realloc((char *) PTR, NEWLENGTH, OLDLENGTH, sizeof(double)) double sqrt(double x); /* count TOTAL number of close pairs */ void paircount( /* inputs */ int *nxy, /* number of (x,y) points */ double *x, double *y, /* (x,y) coordinates */ double *rmaxi, /* maximum distance */ /* output */ int *count ) { int n, maxchunk, i, j, counted; double xi, yi, rmax, r2max, dx, dy, a; n = *nxy; rmax = *rmaxi; r2max = rmax * rmax; *count = counted = 0; if(n == 0) return; /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < n) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > n) maxchunk = n; for(; i < maxchunk; i++) { xi = x[i]; yi = y[i]; if(i > 0) { /* scan backwards from i */ for(j = i - 1; j >= 0; j--) { dx = x[j] - xi; a = r2max - dx * dx; if(a < 0) break; dy = y[j] - yi; a -= dy * dy; if(a >= 0) ++counted; } } if(i + 1 < n) { /* scan forwards from i */ for(j = i + 1; j < n; j++) { dx = x[j] - xi; a = r2max - dx * dx; if(a < 0) break; dy = y[j] - yi; a -= dy * dy; if(a >= 0) ++counted; } } /* end loop over i */ } } *count = counted; } /* analogue for two different point patterns */ void crosscount( /* inputs */ int *nn1, double *x1, double *y1, int *nn2, double *x2, double *y2, double *rmaxi, /* output */ int *count ) { int n1, n2, maxchunk, i, j, jleft, counted; double x1i, y1i, rmax, r2max, xleft, dx, dy, a; n1 = *nn1; n2 = *nn2; rmax = *rmaxi; r2max = rmax * rmax; *count = counted = 0; if(n1 == 0 || n2 == 0) return; jleft = 0; i = 0; maxchunk = 0; while(i < n1) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > n1) maxchunk = n1; for(; i < maxchunk; i++) { x1i = x1[i]; y1i = y1[i]; /* adjust starting index */ xleft = x1i - rmax; while((x2[jleft] < xleft) && (jleft+1 < n2)) ++jleft; /* process from j=jleft until dx > rmax */ for(j=jleft; j < n2; j++) { dx = x2[j] - x1i; a = r2max - dx * dx; if(a < 0) break; dy = y2[j] - y1i; a -= dy * dy; if(a > 0) ++counted; } } } *count = counted; } /* Find duplicated locations xx, yy are not sorted */ void duplicatedxy( /* inputs */ int *n, double *x, double *y, /* output */ int *out /* logical vector */ ) { int m, i, j; double xi, yi; m = *n; for(i = 1; i < m; i++) { R_CheckUserInterrupt(); xi = x[i]; yi = y[i]; for(j = 0; j < i; j++) if((x[j] == xi) && (y[j] == yi)) break; if(j == i) out[i] = 0; else out[i] = 1; } } /* ............... fixed output length .............. */ void Fclosepairs( /* inputs */ int *nxy, double *x, double *y, double *r, int *noutmax, /* outputs */ int *nout, int *iout, int *jout, double *xiout, double *yiout, double *xjout, double *yjout, double *dxout, double *dyout, double *dout, int *status ) { int n, k, kmax, maxchunk, i, j; double xi, yi, rmax, r2max, dx, dy, dx2, d2; n = *nxy; rmax = *r; r2max = rmax * rmax; *status = OK; *nout = 0; k = 0; /* k is the next available storage location and also the current length of the list */ kmax = *noutmax; if(n == 0) return; /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < n) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > n) maxchunk = n; for(; i < maxchunk; i++) { xi = x[i]; yi = y[i]; if(i > 0) { /* scan backwards */ for(j = i - 1; j >= 0; j--) { dx = x[j] - xi; dx2 = dx * dx; if(dx2 > r2max) break; dy = y[j] - yi; d2 = dx2 + dy * dy; if(d2 <= r2max) { /* add this (i, j) pair to output */ if(k >= kmax) { *nout = k; *status = ERR_OVERFLOW; return; } jout[k] = j + 1; /* R indexing */ iout[k] = i + 1; xiout[k] = xi; yiout[k] = yi; xjout[k] = x[j]; yjout[k] = y[j]; dxout[k] = dx; dyout[k] = dy; dout[k] = sqrt(d2); ++k; } } } if(i + 1 < n) { /* scan forwards */ for(j = i + 1; j < n; j++) { dx = x[j] - xi; dx2 = dx * dx; if(dx2 > r2max) break; dy = y[j] - yi; d2 = dx2 + dy * dy; if(d2 <= r2max) { /* add this (i, j) pair to output */ if(k >= kmax) { *nout = k; *status = ERR_OVERFLOW; return; } jout[k] = j + 1; /* R indexing */ iout[k] = i + 1; xiout[k] = xi; yiout[k] = yi; xjout[k] = x[j]; yjout[k] = y[j]; dxout[k] = dx; dyout[k] = dy; dout[k] = sqrt(d2); ++k; } } } } } *nout = k; } void Fcrosspairs( /* inputs */ int *nn1, double *x1, double *y1, int *nn2, double *x2, double *y2, double *rmaxi, int *noutmax, /* outputs */ int *nout, int *iout, int *jout, double *xiout, double *yiout, double *xjout, double *yjout, double *dxout, double *dyout, double *dout, int *status ) { int n1, n2, maxchunk, k, kmax, i, j, jleft; double x1i, y1i, rmax, r2max, xleft, dx, dy, dx2, d2; n1 = *nn1; n2 = *nn2; rmax = *rmaxi; r2max = rmax * rmax; *status = OK; *nout = 0; k = 0; /* k is the next available storage location and also the current length of the list */ kmax = *noutmax; if(n1 == 0 || n2 == 0) return; jleft = 0; i = 0; maxchunk = 0; while(i < n1) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > n1) maxchunk = n1; for(; i < maxchunk; i++) { x1i = x1[i]; y1i = y1[i]; /* adjust starting position jleft */ xleft = x1i - rmax; while((x2[jleft] < xleft) && (jleft+1 < n2)) ++jleft; /* process from j=jleft until dx > rmax */ for(j=jleft; j < n2; j++) { dx = x2[j] - x1i; dx2 = dx * dx; if(dx2 > r2max) break; dy = y2[j] - y1i; d2 = dx2 + dy * dy; if(d2 <= r2max) { /* add this (i, j) pair to output */ if(k >= kmax) { *nout = k; *status = ERR_OVERFLOW; return; } jout[k] = j + 1; /* R indexing */ iout[k] = i + 1; xiout[k] = x1i; yiout[k] = y1i; xjout[k] = x2[j]; yjout[k] = y2[j]; dxout[k] = dx; dyout[k] = dy; dout[k] = sqrt(d2); ++k; } } } } *nout = k; } /* ........ versions that return variable-length vectors ......... */ #define SINGLE /* return i, j only */ #define CLOSEFUN VcloseIJpairs #define CROSSFUN VcrossIJpairs #undef THRESH #undef COORDS #undef DIST #include "closefuns.h" #undef CLOSEFUN #undef CROSSFUN #undef THRESH #undef COORDS #undef DIST /* return i, j, d */ #define CLOSEFUN VcloseIJDpairs #define CROSSFUN VcrossIJDpairs #undef THRESH #undef COORDS #define DIST #include "closefuns.h" #undef CLOSEFUN #undef CROSSFUN #undef THRESH #undef COORDS #undef DIST /* return i, j, xi, yi, xj, yj, dx, dy, d */ #define CLOSEFUN Vclosepairs #define CROSSFUN Vcrosspairs #undef THRESH #define COORDS #define DIST #include "closefuns.h" #undef CLOSEFUN #undef CROSSFUN #undef THRESH #undef COORDS #undef DIST /* return i, j, t where t = 1{d < s} */ #define CLOSEFUN Vclosethresh #define CROSSFUN Vcrossthresh #define THRESH #undef COORDS #include "closefuns.h" #undef CLOSEFUN #undef CROSSFUN #undef THRESH #undef COORDS spatstat.geom/src/minnnd.h0000644000176200001440000000320514611065353015272 0ustar liggesusers/* minnnd.h Code template for minnnd to be #included in minnnd.c Macros: FNAME Function name IGNOREZERO #defined if zero distances should be ignored $Revision: 1.3 $ $Date: 2022/10/21 10:43:01 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ /* THE FOLLOWING CODE ASSUMES THAT y IS SORTED IN ASCENDING ORDER */ void FNAME( /* inputs */ int *n, double *x, double *y, double *huge, /* outputs */ double *result ) { int npoints, i, maxchunk, left, right; double d2, d2min, xi, yi, dx, dy, dy2, hu, hu2; hu = *huge; hu2 = hu * hu; npoints = *n; d2min = hu2; if(npoints == 0) return; /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < npoints) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > npoints) maxchunk = npoints; for(; i < maxchunk; i++) { xi = x[i]; yi = y[i]; if(i < npoints - 1) { /* search forward */ for(right = i + 1; right < npoints; ++right) { dy = y[right] - yi; dy2 = dy * dy; if(dy2 > d2min) break; dx = x[right] - xi; d2 = dx * dx + dy2; if (d2 < d2min) { #ifdef IGNOREZERO if(d2 > 0) d2min = d2; #else d2min = d2; #endif } } } if(i > 0){ /* search backward */ for(left = i - 1; left >= 0; --left) { dy = yi - y[left]; dy2 = dy * dy; if(dy2 > d2min) break; dx = x[left] - xi; d2 = dx * dx + dy2; if (d2 < d2min) { #ifdef IGNOREZERO if(d2 > 0) d2min = d2; #else d2min = d2; #endif } } } } } *result = d2min; } spatstat.geom/src/exactdist.c0000644000176200001440000001403114611065353015771 0ustar liggesusers/* exactdist.c Exact distance transform of a point pattern (used to estimate the empty space function F) $Revision: 1.20 $ $Date: 2022/10/22 09:29:51 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Author: Adrian Baddeley Sketch of functionality: the 'data' are a finite list of points in R^2 (x,y coordinates) and the 'output' is a real valued image whose entries are distances, with the value for each pixel equalling the distance from that pixel to the nearest point of the data pattern. Routines: exact_dt_R() interface to R exact_dt() implementation of distance transform dist_to_bdry() compute distance to edge of image frame shape_raster() initialise a Raster structure The appropriate calling sequence for exact_dt_R() is exemplified in 'exactdt.R' */ #undef DEBUG #include #include "raster.h" #ifdef DEBUG #include #endif void shape_raster(Raster *ras, void *data, double xmin, double ymin, double xmax, double ymax, int nrow, int ncol, int mrow, int mcol); void exact_dt( double *x, double *y, /* data points */ int npt, Raster *dist, /* exact distance to nearest point */ Raster *index /* which point x[i],y[i] is closest */ ) { int i,j,k,l,m; double d; int ii; double dd; /* double bdiag; */ /* initialise rasters */ #define UNDEFINED -1 #define Is_Defined(I) (I >= 0) #define Is_Undefined(I) (I < 0) Clear(*index,int,UNDEFINED) d = 2.0 * DistanceSquared(dist->xmin,dist->ymin,dist->xmax,dist->ymax); Clear(*dist,double,d) /* If the list of data points is empty, ... exit now */ if(npt == 0) return; for(i = 0; i < npt; i++) { /* Rprintf("%ld -> (%lf,%lf)\n", i, x[i], y[i]); */ j = RowIndex(*dist,y[i]); k = ColIndex(*dist,x[i]); /* if(!Inside(*dist,j,k)) Rprintf("(%ld,%ld) out of bounds\n",j,k); else if (!Inside(*dist,j+1,k+1)) Rprintf("(%ld+1,%ld+1) out of bounds\n",j,k); */ for(l = j; l <= j+1; l++) for(m = k; m <= k+1; m++) { d = DistanceToSquared(x[i],y[i],*index,l,m); if( Is_Undefined(Entry(*index,l,m,int)) || Entry(*dist,l,m,double) > d) { /* Rprintf("writing (%ld,%ld) -> %ld\t%lf\n", l,m,i,d); */ Entry(*index,l,m,int) = i; Entry(*dist,l,m,double) = d; /* Rprintf("checking: %ld, %lf\n", Entry(*index,l,m,int), Entry(*dist,l,m,double)); */ } } } /* for(j = 0; j <= index->nrow; j++) for(k = 0; k <= index->ncol; k++) Rprintf("[%ld,%ld] %ld\t%lf\n", j,k,Entry(*index,j,k,int),Entry(*dist,j,k,double)); */ /* how to update the distance values */ #define COMPARE(ROW,COL,RR,CC) \ d = Entry(*dist,ROW,COL,double); \ ii = Entry(*index,RR,CC,int); \ /* Rprintf(" %lf\t (%ld,%ld) |-> %ld\n", d, RR, CC, ii); */ \ if(Is_Defined(ii) /* && ii < npt */ \ && Entry(*dist,RR,CC,double) < d) { \ dd = DistanceSquared(x[ii],y[ii],Xpos(*index,COL),Ypos(*index,ROW)); \ if(dd < d) { \ /* Rprintf("(%ld,%ld) <- %ld\n", ROW, COL, ii); */ \ Entry(*index,ROW,COL,int) = ii; \ Entry(*dist,ROW,COL,double) = dd; \ /* Rprintf("checking: %ld, %lf\n", Entry(*index,ROW,COL,int), Entry(*dist,ROW,COL,double)); */\ } \ } /* bound on diagonal step distance */ /* bdiag = sqrt(index->xstep * index->xstep + index->ystep * index->ystep); */ /* forward pass */ for(j = index->rmin; j <= index->rmax; j++) for(k = index->cmin; k <= index->cmax; k++) { /* Rprintf("Neighbourhood of (%ld,%ld):\n", j,k); */ COMPARE(j,k, j-1,k-1) COMPARE(j,k, j-1, k) COMPARE(j,k, j-1,k+1) COMPARE(j,k, j, k-1) } /* backward pass */ for(j = index->rmax; j >= index->rmin; j--) for(k = index->cmax; k >= index->cmin; k--) { COMPARE(j,k, j+1,k+1) COMPARE(j,k, j+1, k) COMPARE(j,k, j+1,k-1) COMPARE(j,k, j, k+1) } /* take square roots of the distances^2 */ for(j = index->rmin; j <= index->rmax; j++) for(k = index->cmin; k <= index->cmax; k++) Entry(*dist,j,k,double) = sqrt(Entry(*dist,j,k,double)); } #define MIN(A,B) (((A) < (B)) ? (A) : (B)) /* distance to frame boundary from each raster point */ void dist_to_bdry(Raster *d) { int j, k; double x, y, xd, yd, Xmin, Xmax, Ymin, Ymax; /* Frame limits */ Xmin = d->xmin - d->xstep/2.0; Xmax = d->xmax + d->xstep/2.0; Ymin = d->ymin - d->ystep/2.0; Ymax = d->ymax + d->ystep/2.0; #ifdef DEBUG Rprintf("xmin=%lf,xmax=%lf\nymin=%lf,ymax=%lf\n", d->xmin, d->xmax, d->ymin, d->ymax); Rprintf("xstep=%lf,ystep=%lf\n", d->xstep, d->ystep); Rprintf("Xmin=%lf,Xmax=%lf\nYmin=%lf,Ymax=%lf\n", Xmin,Xmax, Ymin, Ymax); Rprintf("(Xpos,Ypos)(cmin,rmin) = (%lf, %lf)\n", Xpos(*d,cmin), Ypos(*d,rmin)); #endif for(j = d->rmin; j <= d->rmax;j++) { y = Ypos(*d,j); yd = MIN(y - Ymin, Ymax - y); for(k = d->cmin; k <= d->cmax;k++) { x = Xpos(*d,k); xd = MIN(x - Xmin, Xmax - x); Entry(*d,j,k,double) = MIN(xd,yd); } } } /* R interface */ void exact_dt_R( double *x, double *y, /* input data points */ int *npt, double *xmin, double *ymin, double *xmax, double *ymax, /* guaranteed bounding box */ int *nr, int *nc, /* desired raster dimensions EXCLUDING margins */ int *mr, int *mc, /* margins */ /* output arrays */ double *distances, /* distance to nearest point */ int *indices, /* index to nearest point */ double *boundary /* distance to boundary */ ) { Raster dist, index, bdist; int mrow, mcol, nrow, ncol; mrow = *mr; mcol = *mc; /* full dimensions */ nrow = *nr + 2 * mrow; ncol = *nc + 2 * mcol; shape_raster( &dist, (void *) distances,*xmin,*ymin,*xmax,*ymax, nrow, ncol, mrow, mcol); shape_raster( &index, (void *) indices, *xmin,*ymin,*xmax,*ymax, nrow, ncol, mrow, mcol); shape_raster( &bdist, (void *) boundary, *xmin,*ymin,*xmax,*ymax, nrow, ncol, mrow, mcol); exact_dt(x, y, (int) *npt, &dist, &index); dist_to_bdry(&bdist); } spatstat.geom/src/trigraf.c0000644000176200001440000006776714611065353015467 0ustar liggesusers/* trigraf.c Form list of all triangles in a planar graph, given list of edges $Revision: 1.17 $ $Date: 2022/10/22 02:52:44 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Form list of all triangles in a planar graph, given list of edges Note: vertex indices ie, je are indices in R. They are handled without converting to C convention, because we only need to test equality and ordering. (*except in 'trioxgraph'*) Called by .C: ------------- trigraf() Generic C implementation with fixed storage limit usable with Delaunay triangulation trigrafS() Faster version when input data are sorted (again with predetermined storage limit) suited for handling Delaunay triangulation Called by .Call: --------------- trigraph() Version with dynamic storage allocation triograph() Faster version assuming 'iedge' is sorted in increasing order trioxgraph() Even faster version for use with quadrature schemes Diameters: ----------- triDgraph() Also computes diameters of triangles */ #include #include #include #include "chunkloop.h" #undef DEBUGTRI void trigraf( /* inputs */ int *nv, /* number of graph vertices */ int *ne, /* number of edges */ int *ie, int *je, /* vectors of indices of ends of each edge */ int *ntmax, /* length of storage space for triangles */ /* output */ int *nt, /* number of triangles (<= *ntmax) */ int *it, int *jt, int *kt, /* vectors of indices of vertices of triangles */ int *status /* 0 if OK, 1 if overflow */ ) { int Nv, Ne, Ntmax; int Nt, Nj, m, i, j, k, mj, mk, maxchunk; int *jj; Nv = *nv; Ne = *ne; Ntmax = *ntmax; /* initialise scratch storage */ jj = (int *) R_alloc(Ne, sizeof(int)); Nt = 0; /* vertex index i ranges from 1 to Nv */ XOUTERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { R_CheckUserInterrupt(); XINNERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { /* Find triangles involving vertex 'i' in which 'i' is the lowest-numbered vertex */ /* First, find vertices j > i connected to i */ Nj = 0; for(m = 0; m < Ne; m++) { if(ie[m] == i) { j = je[m]; if(j > i) { jj[Nj] = j; Nj++; } } else if(je[m] == i) { j = ie[m]; if(j > i) { jj[Nj] = j; Nj++; } } } /* Determine which pairs of vertices j, k are joined by an edge; save triangles (i,j,k) */ if(Nj > 1) { /* Sort jj in ascending order */ for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(k < j) { /* swap */ jj[mk] = j; jj[mj] = k; j = k; } } } for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(j != k) { /* Run through edges to determine whether j, k are neighbours */ for(m = 0; m < Ne; m++) { if((ie[m] == j && je[m] == k) || (ie[m] == k && je[m] == j)) { /* add (i, j, k) to list of triangles */ if(Nt >= Ntmax) { /* overflow - exit */ *status = 1; return; } it[Nt] = i; jt[Nt] = j; kt[Nt] = k; Nt++; } } } } } } } } *nt = Nt; *status = 0; } /* faster version of trigraf() assuming that ie[m] < je[m] ie[] is in ascending order je[] is in ascending order within ie[], that is, je[ie[]=i] is in ascending order for each fixed i */ void trigrafS( /* inputs */ int *nv, /* number of graph vertices */ int *ne, /* number of edges */ int *ie, int *je, /* vectors of indices of ends of each edge */ int *ntmax, /* length of storage space for triangles */ /* output */ int *nt, /* number of triangles */ int *it, int *jt, int *kt, /* vectors of indices of vertices of triangles */ int *status /* 0 if OK, 1 if overflow */ ) { int Ne, Nt, Ntmax; int m, i, j, k, mj, mk; int firstedge, lastedge; Ne = *ne; Ntmax = *ntmax; /* nv is not used, but retained for harmony with trigraf */ /* Avoid compiler warnings */ Nt = *nv; /* initialise output */ Nt = 0; lastedge = -1; while(lastedge + 1 < Ne) { if(lastedge % 256 == 0) R_CheckUserInterrupt(); /* Consider next vertex i. The edges (i,j) with i < j appear contiguously in the edge list. */ firstedge = lastedge + 1; i = ie[firstedge]; for(m= firstedge+1; m < Ne && ie[m] == i; m++) ; lastedge = m-1; /* Consider each pair j, k of neighbours of i, where i < j < k. Scan entire edge list to determine whether j, k are joined by an edge. If so, save triangle (i,j,k) */ if(lastedge > firstedge) { for(mj = firstedge; mj < lastedge; mj++) { j = je[mj]; for(mk = firstedge+1; mk <= lastedge; mk++) { k = je[mk]; /* Run through edges to determine whether j, k are neighbours */ for(m = 0; m < Ne && ie[m] < j; m++) ; while(m < Ne && ie[m] == j) { if(je[m] == k) { /* add (i, j, k) to list of triangles */ if(Nt >= Ntmax) { /* overflow - exit */ *status = 1; return; } it[Nt] = i; jt[Nt] = j; kt[Nt] = k; Nt++; } m++; } } } } } *nt = Nt; *status = 0; } /* ------------------- callable by .Call ------------------------- */ SEXP trigraph(SEXP nv, /* number of vertices */ SEXP iedge, /* vectors of indices of ends of each edge */ SEXP jedge) /* all arguments are integer */ { int Nv, Ne; int *ie, *je; /* edges */ int *it, *jt, *kt; /* vectors of indices of vertices of triangles */ int Nt, Ntmax; /* number of triangles */ int Nj; int *jj; /* scratch storage */ int i, j, k, m, mj, mk, Nmore, maxchunk; /* output */ SEXP iTout, jTout, kTout, out; int *ito, *jto, *kto; /* =================== Protect R objects from garbage collector ======= */ PROTECT(nv = AS_INTEGER(nv)); PROTECT(iedge = AS_INTEGER(iedge)); PROTECT(jedge = AS_INTEGER(jedge)); /* That's 3 protected objects */ /* numbers of vertices and edges */ Nv = *(INTEGER_POINTER(nv)); Ne = LENGTH(iedge); /* input arrays */ ie = INTEGER_POINTER(iedge); je = INTEGER_POINTER(jedge); /* initialise storage (with a guess at max size) */ Ntmax = 3 * Ne; it = (int *) R_alloc(Ntmax, sizeof(int)); jt = (int *) R_alloc(Ntmax, sizeof(int)); kt = (int *) R_alloc(Ntmax, sizeof(int)); Nt = 0; /* initialise scratch storage */ jj = (int *) R_alloc(Ne, sizeof(int)); XOUTERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { R_CheckUserInterrupt(); XINNERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { #ifdef DEBUGTRI Rprintf("i=%d ---------- \n", i); #endif /* Find triangles involving vertex 'i' in which 'i' is the lowest-numbered vertex */ /* First, find vertices j > i connected to i */ Nj = 0; for(m = 0; m < Ne; m++) { if(ie[m] == i) { j = je[m]; if(j > i) { jj[Nj] = j; Nj++; } } else if(je[m] == i) { j = ie[m]; if(j > i) { jj[Nj] = j; Nj++; } } } /* Determine which pairs of vertices j, k are joined by an edge; save triangles (i,j,k) */ #ifdef DEBUGTRI Rprintf("Nj = %d\n", Nj); #endif if(Nj > 1) { #ifdef DEBUGTRI Rprintf("i=%d\njj=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif /* Sort jj in ascending order */ for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(k < j) { /* swap */ jj[mk] = j; jj[mj] = k; j = k; } } } #ifdef DEBUGTRI Rprintf("sorted=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(j != k) { /* Run through edges to determine whether j, k are neighbours */ for(m = 0; m < Ne; m++) { if((ie[m] == j && je[m] == k) || (ie[m] == k && je[m] == j)) { /* add (i, j, k) to list of triangles */ if(Nt >= Ntmax) { /* overflow - allocate more space */ Nmore = 2 * Ntmax; #ifdef DEBUGTRI Rprintf("Doubling space from %d to %d\n", Ntmax, Nmore); #endif it = (int *) S_realloc((char *) it, Nmore, Ntmax, sizeof(int)); jt = (int *) S_realloc((char *) jt, Nmore, Ntmax, sizeof(int)); kt = (int *) S_realloc((char *) kt, Nmore, Ntmax, sizeof(int)); Ntmax = Nmore; } /* output indices in R convention */ it[Nt] = i; jt[Nt] = j; kt[Nt] = k; Nt++; } } } } } } } } /* allocate space for output */ PROTECT(iTout = NEW_INTEGER(Nt)); PROTECT(jTout = NEW_INTEGER(Nt)); PROTECT(kTout = NEW_INTEGER(Nt)); PROTECT(out = NEW_LIST(3)); /* that's 3+4=7 protected objects */ ito = INTEGER_POINTER(iTout); jto = INTEGER_POINTER(jTout); kto = INTEGER_POINTER(kTout); /* copy triangle indices to output vectors */ for(m = 0; m < Nt; m++) { ito[m] = it[m]; jto[m] = jt[m]; kto[m] = kt[m]; } /* insert output vectors in output list */ SET_VECTOR_ELT(out, 0, iTout); SET_VECTOR_ELT(out, 1, jTout); SET_VECTOR_ELT(out, 2, kTout); UNPROTECT(7); return(out); } /* faster version assuming iedge is in increasing order */ SEXP triograph(SEXP nv, /* number of vertices */ SEXP iedge, /* vectors of indices of ends of each edge */ SEXP jedge) /* all arguments are integer */ { int Nv, Ne; int *ie, *je; /* edges */ int *it, *jt, *kt; /* vectors of indices of vertices of triangles */ int Nt, Ntmax; /* number of triangles */ int Nj; int *jj; /* scratch storage */ int i, j, k, m, mj, mk, maxjk, Nmore, maxchunk; /* output */ SEXP iTout, jTout, kTout, out; int *ito, *jto, *kto; /* =================== Protect R objects from garbage collector ======= */ PROTECT(nv = AS_INTEGER(nv)); PROTECT(iedge = AS_INTEGER(iedge)); PROTECT(jedge = AS_INTEGER(jedge)); /* That's 3 protected objects */ /* numbers of vertices and edges */ Nv = *(INTEGER_POINTER(nv)); Ne = LENGTH(iedge); /* input arrays */ ie = INTEGER_POINTER(iedge); je = INTEGER_POINTER(jedge); /* initialise storage (with a guess at max size) */ Ntmax = 3 * Ne; it = (int *) R_alloc(Ntmax, sizeof(int)); jt = (int *) R_alloc(Ntmax, sizeof(int)); kt = (int *) R_alloc(Ntmax, sizeof(int)); Nt = 0; /* initialise scratch storage */ jj = (int *) R_alloc(Ne, sizeof(int)); XOUTERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { R_CheckUserInterrupt(); XINNERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { #ifdef DEBUGTRI Rprintf("i=%d ---------- \n", i); #endif /* Find triangles involving vertex 'i' in which 'i' is the lowest-numbered vertex */ /* First, find vertices j > i connected to i */ Nj = 0; for(m = 0; m < Ne; m++) { if(ie[m] == i) { j = je[m]; if(j > i) { jj[Nj] = j; Nj++; } } else if(je[m] == i) { j = ie[m]; if(j > i) { jj[Nj] = j; Nj++; } } } /* Determine which pairs of vertices j, k are joined by an edge; save triangles (i,j,k) */ #ifdef DEBUGTRI Rprintf("Nj = %d\n", Nj); #endif if(Nj > 1) { #ifdef DEBUGTRI Rprintf("i=%d\njj=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif /* Sort jj in ascending order */ for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(k < j) { /* swap */ jj[mk] = j; jj[mj] = k; j = k; } } } #ifdef DEBUGTRI Rprintf("sorted=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(j != k) { /* Run through edges to determine whether j, k are neighbours */ maxjk = (j > k) ? j : k; for(m = 0; m < Ne; m++) { if(ie[m] > maxjk) break; /* since iedge is in increasing order, the test below will always be FALSE when ie[m] > max(j,k) */ if((ie[m] == j && je[m] == k) || (ie[m] == k && je[m] == j)) { /* add (i, j, k) to list of triangles */ if(Nt >= Ntmax) { /* overflow - allocate more space */ Nmore = 2 * Ntmax; #ifdef DEBUGTRI Rprintf("Doubling space from %d to %d\n", Ntmax, Nmore); #endif it = (int *) S_realloc((char *) it, Nmore, Ntmax, sizeof(int)); jt = (int *) S_realloc((char *) jt, Nmore, Ntmax, sizeof(int)); kt = (int *) S_realloc((char *) kt, Nmore, Ntmax, sizeof(int)); Ntmax = Nmore; } it[Nt] = i; jt[Nt] = j; kt[Nt] = k; Nt++; } } } } } } } } /* allocate space for output */ PROTECT(iTout = NEW_INTEGER(Nt)); PROTECT(jTout = NEW_INTEGER(Nt)); PROTECT(kTout = NEW_INTEGER(Nt)); PROTECT(out = NEW_LIST(3)); /* that's 3+4=7 protected objects */ ito = INTEGER_POINTER(iTout); jto = INTEGER_POINTER(jTout); kto = INTEGER_POINTER(kTout); /* copy triangle indices to output vectors */ for(m = 0; m < Nt; m++) { ito[m] = it[m]; jto[m] = jt[m]; kto[m] = kt[m]; } /* insert output vectors in output list */ SET_VECTOR_ELT(out, 0, iTout); SET_VECTOR_ELT(out, 1, jTout); SET_VECTOR_ELT(out, 2, kTout); UNPROTECT(7); return(out); } /* Even faster version using information about dummy vertices. Dummy-to-dummy edges are forbidden. For generic purposes use 'friendly' for 'isdata' Edge between j and k is possible iff friendly[j] || friendly[k]. Edges with friendly = FALSE cannot be connected to one another. */ SEXP trioxgraph(SEXP nv, /* number of vertices */ SEXP iedge, /* vectors of indices of ends of each edge */ SEXP jedge, SEXP friendly) /* indicator vector, length nv */ { /* input */ int Nv, Ne; int *ie, *je; /* edges */ int *friend; /* indicator */ /* output */ int *it, *jt, *kt; /* vectors of indices of vertices of triangles */ int Nt, Ntmax; /* number of triangles */ /* scratch storage */ int Nj; int *jj; int i, j, k, m, mj, mk, maxjk, Nmore, maxchunk; /* output to R */ SEXP iTout, jTout, kTout, out; int *ito, *jto, *kto; /* =================== Protect R objects from garbage collector ======= */ PROTECT(nv = AS_INTEGER(nv)); PROTECT(iedge = AS_INTEGER(iedge)); PROTECT(jedge = AS_INTEGER(jedge)); PROTECT(friendly = AS_INTEGER(friendly)); /* That's 4 protected objects */ /* numbers of vertices and edges */ Nv = *(INTEGER_POINTER(nv)); Ne = LENGTH(iedge); /* input arrays */ ie = INTEGER_POINTER(iedge); je = INTEGER_POINTER(jedge); friend = INTEGER_POINTER(friendly); /* initialise storage (with a guess at max size) */ Ntmax = 3 * Ne; it = (int *) R_alloc(Ntmax, sizeof(int)); jt = (int *) R_alloc(Ntmax, sizeof(int)); kt = (int *) R_alloc(Ntmax, sizeof(int)); Nt = 0; /* initialise scratch storage */ jj = (int *) R_alloc(Ne, sizeof(int)); /* convert to C indexing convention */ for(m = 0; m < Ne; m++) { ie[m] -= 1; je[m] -= 1; } OUTERCHUNKLOOP(i, Nv, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, Nv, maxchunk, 8196) { #ifdef DEBUGTRI Rprintf("i=%d ---------- \n", i); #endif /* Find triangles involving vertex 'i' in which 'i' is the lowest-numbered vertex */ /* First, find vertices j > i connected to i */ Nj = 0; for(m = 0; m < Ne; m++) { if(ie[m] == i) { j = je[m]; if(j > i) { jj[Nj] = j; Nj++; } } else if(je[m] == i) { j = ie[m]; if(j > i) { jj[Nj] = j; Nj++; } } } /* Determine which pairs of vertices j, k are joined by an edge; save triangles (i,j,k) */ #ifdef DEBUGTRI Rprintf("Nj = %d\n", Nj); #endif if(Nj > 1) { #ifdef DEBUGTRI Rprintf("i=%d\njj=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif /* Sort jj in ascending order */ for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(k < j) { /* swap */ jj[mk] = j; jj[mj] = k; j = k; } } } #ifdef DEBUGTRI Rprintf("sorted=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(j != k && (friend[j] || friend[k])) { /* Run through edges to determine whether j, k are neighbours */ maxjk = (j > k) ? j : k; for(m = 0; m < Ne; m++) { if(ie[m] > maxjk) break; /* since iedge is in increasing order, the test below will always be FALSE when ie[m] > max(j,k) */ if((ie[m] == j && je[m] == k) || (ie[m] == k && je[m] == j)) { /* add (i, j, k) to list of triangles */ if(Nt >= Ntmax) { /* overflow - allocate more space */ Nmore = 2 * Ntmax; #ifdef DEBUGTRI Rprintf("Doubling space from %d to %d\n", Ntmax, Nmore); #endif it = (int *) S_realloc((char *) it, Nmore, Ntmax, sizeof(int)); jt = (int *) S_realloc((char *) jt, Nmore, Ntmax, sizeof(int)); kt = (int *) S_realloc((char *) kt, Nmore, Ntmax, sizeof(int)); Ntmax = Nmore; } /* convert back to R indexing */ it[Nt] = i + 1; jt[Nt] = j + 1; kt[Nt] = k + 1; Nt++; } } } } } } } } /* allocate space for output */ PROTECT(iTout = NEW_INTEGER(Nt)); PROTECT(jTout = NEW_INTEGER(Nt)); PROTECT(kTout = NEW_INTEGER(Nt)); PROTECT(out = NEW_LIST(3)); /* that's 4+4=8 protected objects */ ito = INTEGER_POINTER(iTout); jto = INTEGER_POINTER(jTout); kto = INTEGER_POINTER(kTout); /* copy triangle indices to output vectors */ for(m = 0; m < Nt; m++) { ito[m] = it[m]; jto[m] = jt[m]; kto[m] = kt[m]; } /* insert output vectors in output list */ SET_VECTOR_ELT(out, 0, iTout); SET_VECTOR_ELT(out, 1, jTout); SET_VECTOR_ELT(out, 2, kTout); UNPROTECT(8); return(out); } /* also calculates diameter (max edge length) of triangle */ SEXP triDgraph(SEXP nv, /* number of vertices */ SEXP iedge, /* vectors of indices of ends of each edge */ SEXP jedge, SEXP edgelength) /* edge lengths */ { int Nv, Ne; int *ie, *je; /* edges */ double *edgelen; int *it, *jt, *kt; /* vectors of indices of vertices of triangles */ double *dt; /* diameters (max edge lengths) of triangles */ int Nt, Ntmax; /* number of triangles */ /* scratch storage */ int Nj; int *jj; double *dd; int i, j, k, m, mj, mk, Nmore, maxchunk; double dij, dik, djk, diam; /* output */ SEXP iTout, jTout, kTout, dTout, out; int *ito, *jto, *kto; double *dto; /* =================== Protect R objects from garbage collector ======= */ PROTECT(nv = AS_INTEGER(nv)); PROTECT(iedge = AS_INTEGER(iedge)); PROTECT(jedge = AS_INTEGER(jedge)); PROTECT(edgelength = AS_NUMERIC(edgelength)); /* That's 4 protected objects */ /* numbers of vertices and edges */ Nv = *(INTEGER_POINTER(nv)); Ne = LENGTH(iedge); /* input arrays */ ie = INTEGER_POINTER(iedge); je = INTEGER_POINTER(jedge); edgelen = NUMERIC_POINTER(edgelength); /* initialise storage (with a guess at max size) */ Ntmax = 3 * Ne; it = (int *) R_alloc(Ntmax, sizeof(int)); jt = (int *) R_alloc(Ntmax, sizeof(int)); kt = (int *) R_alloc(Ntmax, sizeof(int)); dt = (double *) R_alloc(Ntmax, sizeof(double)); Nt = 0; /* initialise scratch storage */ jj = (int *) R_alloc(Ne, sizeof(int)); dd = (double *) R_alloc(Ne, sizeof(double)); XOUTERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { R_CheckUserInterrupt(); XINNERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { #ifdef DEBUGTRI Rprintf("i=%d ---------- \n", i); #endif /* Find triangles involving vertex 'i' in which 'i' is the lowest-numbered vertex */ /* First, find vertices j > i connected to i */ Nj = 0; for(m = 0; m < Ne; m++) { if(ie[m] == i) { j = je[m]; if(j > i) { jj[Nj] = j; dd[Nj] = edgelen[m]; Nj++; } } else if(je[m] == i) { j = ie[m]; if(j > i) { jj[Nj] = j; dd[Nj] = edgelen[m]; Nj++; } } } /* Determine which pairs of vertices j, k are joined by an edge; save triangles (i,j,k) */ #ifdef DEBUGTRI Rprintf("Nj = %d\n", Nj); #endif if(Nj > 1) { #ifdef DEBUGTRI Rprintf("i=%d\njj=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif /* Sort jj in ascending order */ for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(k < j) { /* swap */ jj[mk] = j; jj[mj] = k; dik = dd[mj]; dd[mj] = dd[mk]; dd[mk] = dik; j = k; } } } #ifdef DEBUGTRI Rprintf("sorted=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; dij = dd[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; dik = dd[mk]; if(j != k) { /* Run through edges to determine whether j, k are neighbours */ for(m = 0; m < Ne; m++) { if((ie[m] == j && je[m] == k) || (ie[m] == k && je[m] == j)) { /* triangle (i, j, k) */ /* determine triangle diameter */ diam = (dij > dik) ? dij : dik; djk = edgelen[m]; if(djk > diam) diam = djk; /* add (i, j, k) to list of triangles */ if(Nt >= Ntmax) { /* overflow - allocate more space */ Nmore = 2 * Ntmax; #ifdef DEBUGTRI Rprintf("Doubling space from %d to %d\n", Ntmax, Nmore); #endif it = (int *) S_realloc((char *) it, Nmore, Ntmax, sizeof(int)); jt = (int *) S_realloc((char *) jt, Nmore, Ntmax, sizeof(int)); kt = (int *) S_realloc((char *) kt, Nmore, Ntmax, sizeof(int)); dt = (double *) S_realloc((char *) dt, Nmore, Ntmax, sizeof(double)); Ntmax = Nmore; } it[Nt] = i; jt[Nt] = j; kt[Nt] = k; dt[Nt] = diam; Nt++; } } } } } } } } /* allocate space for output */ PROTECT(iTout = NEW_INTEGER(Nt)); PROTECT(jTout = NEW_INTEGER(Nt)); PROTECT(kTout = NEW_INTEGER(Nt)); PROTECT(dTout = NEW_NUMERIC(Nt)); PROTECT(out = NEW_LIST(4)); /* that's 4+5=9 protected objects */ ito = INTEGER_POINTER(iTout); jto = INTEGER_POINTER(jTout); kto = INTEGER_POINTER(kTout); dto = NUMERIC_POINTER(dTout); /* copy triangle indices to output vectors */ for(m = 0; m < Nt; m++) { ito[m] = it[m]; jto[m] = jt[m]; kto[m] = kt[m]; dto[m] = dt[m]; } /* insert output vectors in output list */ SET_VECTOR_ELT(out, 0, iTout); SET_VECTOR_ELT(out, 1, jTout); SET_VECTOR_ELT(out, 2, kTout); SET_VECTOR_ELT(out, 3, dTout); UNPROTECT(9); return(out); } /* same as triDgraph but returns only triangles with diameter <= dmax */ SEXP triDRgraph(SEXP nv, /* number of vertices */ SEXP iedge, /* vectors of indices of ends of each edge */ SEXP jedge, SEXP edgelength, /* edge lengths */ SEXP dmax) { int Nv, Ne; int *ie, *je; /* edges */ double *edgelen; int *it, *jt, *kt; /* vectors of indices of vertices of triangles */ double *dt; /* diameters (max edge lengths) of triangles */ int Nt, Ntmax; /* number of triangles */ /* scratch storage */ int Nj; int *jj; double *dd; int i, j, k, m, mj, mk, Nmore, maxchunk; double dij, dik, djk, diam, Dmax; /* output */ SEXP iTout, jTout, kTout, dTout, out; int *ito, *jto, *kto; double *dto; /* =================== Protect R objects from garbage collector ======= */ PROTECT(nv = AS_INTEGER(nv)); PROTECT(iedge = AS_INTEGER(iedge)); PROTECT(jedge = AS_INTEGER(jedge)); PROTECT(edgelength = AS_NUMERIC(edgelength)); PROTECT(dmax = AS_NUMERIC(dmax)); /* That's 5 protected objects */ /* numbers of vertices and edges */ Nv = *(INTEGER_POINTER(nv)); Ne = LENGTH(iedge); /* input arrays */ ie = INTEGER_POINTER(iedge); je = INTEGER_POINTER(jedge); edgelen = NUMERIC_POINTER(edgelength); /* maximum diameter */ Dmax = *(NUMERIC_POINTER(dmax)); /* initialise storage (with a guess at max size) */ Ntmax = 3 * Ne; it = (int *) R_alloc(Ntmax, sizeof(int)); jt = (int *) R_alloc(Ntmax, sizeof(int)); kt = (int *) R_alloc(Ntmax, sizeof(int)); dt = (double *) R_alloc(Ntmax, sizeof(double)); Nt = 0; /* initialise scratch storage */ jj = (int *) R_alloc(Ne, sizeof(int)); dd = (double *) R_alloc(Ne, sizeof(double)); XOUTERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { R_CheckUserInterrupt(); XINNERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { #ifdef DEBUGTRI Rprintf("i=%d ---------- \n", i); #endif /* Find triangles involving vertex 'i' in which 'i' is the lowest-numbered vertex */ /* First, find vertices j > i connected to i */ Nj = 0; for(m = 0; m < Ne; m++) { if(ie[m] == i) { j = je[m]; if(j > i) { jj[Nj] = j; dd[Nj] = edgelen[m]; Nj++; } } else if(je[m] == i) { j = ie[m]; if(j > i) { jj[Nj] = j; dd[Nj] = edgelen[m]; Nj++; } } } /* Determine which pairs of vertices j, k are joined by an edge; save triangles (i,j,k) */ #ifdef DEBUGTRI Rprintf("Nj = %d\n", Nj); #endif if(Nj > 1) { #ifdef DEBUGTRI Rprintf("i=%d\njj=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif /* Sort jj in ascending order */ for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(k < j) { /* swap */ jj[mk] = j; jj[mj] = k; dik = dd[mj]; dd[mj] = dd[mk]; dd[mk] = dik; j = k; } } } #ifdef DEBUGTRI Rprintf("sorted=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; dij = dd[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; dik = dd[mk]; if(j != k) { /* Run through edges to determine whether j, k are neighbours */ for(m = 0; m < Ne; m++) { if((ie[m] == j && je[m] == k) || (ie[m] == k && je[m] == j)) { /* triangle (i, j, k) */ /* determine triangle diameter */ diam = (dij > dik) ? dij : dik; djk = edgelen[m]; if(djk > diam) diam = djk; if(diam <= Dmax) { /* add (i, j, k) to list of triangles */ if(Nt >= Ntmax) { /* overflow - allocate more space */ Nmore = 2 * Ntmax; #ifdef DEBUGTRI Rprintf("Doubling space from %d to %d\n", Ntmax, Nmore); #endif it = (int *) S_realloc((char *) it, Nmore, Ntmax, sizeof(int)); jt = (int *) S_realloc((char *) jt, Nmore, Ntmax, sizeof(int)); kt = (int *) S_realloc((char *) kt, Nmore, Ntmax, sizeof(int)); dt = (double *) S_realloc((char *) dt, Nmore, Ntmax, sizeof(double)); Ntmax = Nmore; } it[Nt] = i; jt[Nt] = j; kt[Nt] = k; dt[Nt] = diam; Nt++; } } } } } } } } } /* allocate space for output */ PROTECT(iTout = NEW_INTEGER(Nt)); PROTECT(jTout = NEW_INTEGER(Nt)); PROTECT(kTout = NEW_INTEGER(Nt)); PROTECT(dTout = NEW_NUMERIC(Nt)); PROTECT(out = NEW_LIST(4)); /* that's 5+5=10 protected objects */ ito = INTEGER_POINTER(iTout); jto = INTEGER_POINTER(jTout); kto = INTEGER_POINTER(kTout); dto = NUMERIC_POINTER(dTout); /* copy triangle indices to output vectors */ for(m = 0; m < Nt; m++) { ito[m] = it[m]; jto[m] = jt[m]; kto[m] = kt[m]; dto[m] = dt[m]; } /* insert output vectors in output list */ SET_VECTOR_ELT(out, 0, iTout); SET_VECTOR_ELT(out, 1, jTout); SET_VECTOR_ELT(out, 2, kTout); SET_VECTOR_ELT(out, 3, dTout); UNPROTECT(10); return(out); } spatstat.geom/src/raster.c0000644000176200001440000000200414611065353015276 0ustar liggesusers/* raster.c shape_raster() initialise a Raster structure $Revision: 1.2 $ $Date: 2022/10/22 02:32:10 $ */ #include #include "raster.h" void shape_raster( /* the raster structure to be initialised */ Raster *ras, /* pointer to data storage for pixel values */ void *data, /* range of GRID COORDS excluding margin */ double xmin, double ymin, double xmax, double ymax, /* absolute dimensions of storage array */ int nrow, int ncol, /* margins for working */ int mrow, int mcol ) { ras->data = data; ras->nrow = nrow; ras->ncol = ncol; ras->length = nrow * ncol; ras->rmin = mrow; ras->rmax = nrow - mrow - 1; ras->cmin = mcol; ras->cmax = ncol - mcol - 1; ras->x0 = ras->xmin = xmin; ras->x1 = ras->xmax = xmax; ras->y0 = ras->ymin = ymin; ras->y1 = ras->ymax = ymax; ras->xstep = (xmax-xmin)/(ncol - 2 * mcol - 1); ras->ystep = (ymax-ymin)/(nrow - 2 * mrow - 1); /* Rprintf("xstep,ystep = %lf,%lf\n", ras->xstep,ras->ystep); */ } spatstat.geom/src/connectpix.h0000644000176200001440000000433514611065353016166 0ustar liggesusers/* connectpix.h Code template for connected component transform of image This file is #included multiple times in 'connectpix.c' using macros INAME Internal workhorse function name RNAME R interface function name STYPE Pixel value storage type (int or double) CONN connectivity (4 or 8) $Revision: 1.6 $ $Date: 2023/07/18 03:45:27 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2023 Licence: GNU Public Licence >= 2 */ /* First the internal workhorse function */ void INAME(Raster *im) /* raster must have been dimensioned by shape_raster() */ /* Pixel values assumed to be 0 in background, and distinct nonzero values in foreground */ { int j,k; int rmin, rmax, cmin, cmax; STYPE label, curlabel, minlabel; int anychanged; /* image boundaries */ rmin = im->rmin; rmax = im->rmax; cmin = im->cmin; cmax = im->cmax; anychanged = 1; #define ENTRY(ROW, COL) Entry(*im, ROW, COL, STYPE) #define UPDATE(ROW,COL,BEST,NEW) \ NEW = ENTRY(ROW, COL); \ if(NEW != 0 && NEW < BEST) \ BEST = NEW while(anychanged != 0) { anychanged = 0; R_CheckUserInterrupt(); for(j = rmin; j <= rmax; j++) { for(k = cmin; k <= cmax; k++) { curlabel = ENTRY(j, k); if(curlabel != 0) { minlabel = curlabel; #if (CONN == 8) UPDATE(j-1, k-1, minlabel, label); #endif UPDATE(j-1, k, minlabel, label); #if (CONN == 8) UPDATE(j-1, k+1, minlabel, label); #endif UPDATE(j, k-1, minlabel, label); UPDATE(j, k, minlabel, label); UPDATE(j, k+1, minlabel, label); #if (CONN == 8) UPDATE(j+1, k-1, minlabel, label); #endif UPDATE(j+1, k, minlabel, label); #if (CONN == 8) UPDATE(j+1, k+1, minlabel, label); #endif if(minlabel < curlabel) { ENTRY(j, k) = minlabel; anychanged = 1; } } } } } } /* The R interface function */ void RNAME( STYPE *mat, /* input */ int *nr, int *nc /* raster dimensions EXCLUDING margin of 1 on each side */ ) { Raster im; shape_raster( &im, (void *) mat, (double) 1, (double) 1, (double) *nc, (double) *nr, *nr+2, *nc+2, 1, 1); INAME(&im); } #undef ENTRY #undef UPDATE spatstat.geom/src/fardist.c0000644000176200001440000000071414611065353015440 0ustar liggesusers/* fardist.c Furthest data point from each grid point Uses code template 'fardist.h' Copyright (C) Adrian Baddeley, Rolf Turner and Ege Rubak 2014 Licence: GPL >= 2 $Revision: 1.3 $ $Date: 2022/10/22 09:29:51 $ */ #include #include #include double sqrt(double x); #define FNAME fardistgrid #undef SQUARED #include "fardist.h" #undef FNAME #define FNAME fardist2grid #define SQUARED #include "fardist.h" spatstat.geom/src/knn3Ddist.h0000644000176200001440000000764314611065353015662 0ustar liggesusers/* knn3Ddist.h Code template for k-nearest-neighbour algorithms for 3D point patterns Input is a single point pattern - supports 'nndist' and 'nnwhich' This code is #included multiple times in nn3Ddist.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour Either or both DIST and WHICH may be defined. THE FOLLOWING CODE ASSUMES THAT THE POINT PATTERN IS SORTED IN ASCENDING ORDER OF THE z COORDINATE $Revision: 1.5 $ $Date: 2022/10/21 10:43:01 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ void FNAME( /* inputs */ int *n, /* number of points */ int *kmax, /* maximum order of neighbours (1=nearest) */ double *x, double *y, double *z, /* output matrices (n * kmax) in ROW MAJOR order */ double *nnd, int *nnwhich, /* upper bound on the distance between any pair of points */ double *huge ) { int npoints, nk, nk1, i, j, k, k1, unsorted, maxchunk; double d2, d2minK, xi, yi, zi, dx, dy, dz, dz2, hu, hu2, tmp; double *d2min; #ifdef WHICH int *which; int itmp; #endif hu = *huge; hu2 = hu * hu; npoints = *n; nk = *kmax; nk1 = nk - 1; /* create space to store the nearest neighbour distances and indices for the current point */ d2min = (double *) R_alloc((size_t) nk, sizeof(double)); #ifdef WHICH which = (int *) R_alloc((size_t) nk, sizeof(int)); #endif /* loop over points */ OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { #ifdef SPATSTAT_DEBUG Rprintf("\ni=%d\n", i); #endif /* initialise nn distances and indices */ d2minK = hu2; for(k = 0; k < nk; k++) { d2min[k] = hu2; #ifdef WHICH which[k] = -1; #endif } xi = x[i]; yi = y[i]; zi = z[i]; /* search backward */ if(i > 0) { for(j = i - 1; j >= 0; --j) { #ifdef SPATSTAT_DEBUG Rprintf("L"); #endif dz = z[j] - zi; dz2 = dz * dz; if(dz2 > d2minK) break; dx = x[j] - xi; dy = y[j] - yi; d2 = dx * dx + dy * dy + dz2; if (d2 < d2minK) { /* overwrite last entry */ d2min[nk1] = d2; #ifdef WHICH which[nk1] = j; #endif /* bubble sort */ unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } /* adjust maximum distance */ d2minK = d2min[nk1]; } } } /* search forward */ if(i + 1 < npoints) { for(j = i + 1; j < npoints; ++j) { #ifdef SPATSTAT_DEBUG Rprintf("R"); #endif dz = z[j] - zi; dz2 = dz * dz; if(dz2 > d2minK) break; dx = x[j] - xi; dy = y[j] - yi; d2 = dx * dx + dy * dy + dz2; if (d2 < d2minK) { /* overwrite last entry */ d2min[nk1] = d2; #ifdef WHICH which[nk1] = j; #endif /* bubble sort */ unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } /* adjust maximum distance */ d2minK = d2min[nk1]; } } } #ifdef SPATSTAT_DEBUG Rprintf("\n"); #endif /* calculate nn distances for point i and copy to output matrix in ROW MAJOR order */ for(k = 0; k < nk; k++) { #ifdef DIST nnd[nk * i + k] = sqrt(d2min[k]); #endif #ifdef WHICH /* convert from C to R indexing */ nnwhich[nk * i + k] = which[k] + 1; #endif } } } } spatstat.geom/src/loccums.h0000644000176200001440000000411714611065353015457 0ustar liggesusers/* loccums.h C template for loccum.c data-to-data functions $Revision: 1.7 $ $Date: 2022/10/21 10:43:01 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 macros: FNAME function name NULVAL initial value (empty sum = 0, empty product = 1) INC(A,B) increment operation A += B or A *= B */ void FNAME( /* inputs */ int *n, double *x, double *y, double *v, int *nr, double *rmax, /* output */ double *ans /* matrix of column vectors of functions for each point */ ) { int N, Nr, Nans; double Rmax; int i, j, k, kmin, maxchunk, columnstart; double Rmax2, rstep, xi, yi; double dx, dy, dx2, d2, d, contrib; N = *n; Nr = *nr; Rmax = *rmax; if(N == 0) return; rstep = Rmax/(Nr-1); Rmax2 = Rmax * Rmax; Nans = Nr * N; /* initialise products to 1 */ OUTERCHUNKLOOP(k, Nans, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(k, Nans, maxchunk, 8196) { ans[k] = NULVAL; } } OUTERCHUNKLOOP(i, N, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, N, maxchunk, 8196) { xi = x[i]; yi = y[i]; columnstart = Nr * i; /* start position for f_i(.) in 'ans' */ /* process backward until |dx| > Rmax */ if(i > 0) { for(j=i-1; j >= 0; j--) { dx = x[j] - xi; dx2 = dx * dx; if(dx2 > Rmax2) break; dy = y[j] - yi; d2 = dx2 + dy * dy; if(d2 <= Rmax2) { d = sqrt(d2); kmin = (int) ceil(d/rstep); if(kmin < Nr) { contrib = v[j]; for(k = kmin; k < Nr; k++) INC(ans[columnstart + k] , contrib); } } } } /* process forward until |dx| > Rmax */ if(i < N - 1) { for(j=i+1; j < N; j++) { dx = x[j] - xi; dx2 = dx * dx; if(dx2 > Rmax2) break; dy = y[j] - yi; d2 = dx2 + dy * dy; if(d2 <= Rmax2) { d = sqrt(d2); kmin = (int) ceil(d/rstep); if(kmin < Nr) { contrib = v[j]; for(k = kmin; k < Nr; k++) INC(ans[columnstart + k] , contrib); } } } } } } } spatstat.geom/src/raster.h0000644000176200001440000000523014611065353015307 0ustar liggesusers/* raster.h Definition of raster structures & operations requires (for floor()) $Revision: 1.6 $ $Date: 2022/03/15 02:19:08 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ typedef struct Raster{ /* array of data */ char *data; /* coerced to appropriate type */ int nrow; /* dimensions of entire array */ int ncol; int length; int rmin; /* position of valid subrectangle */ int rmax; int cmin; int cmax; /* definition of mapping into continuous space */ double x0; /* position of entry (rmin,cmin) */ double y0; double x1; /* position of entry (rmax,cmax) */ double y1; double xstep; /* x increment for each column step */ double ystep; /* y increment for each row step */ /* xstep = (x1 - x0)/(cmax - cmin) = (x1 - x0)/(number of valid columns - 1) CAN BE POSITIVE OR NEGATIVE */ /* ranges of grid coordinates */ double xmin; /* = min{x0,x1} */ double xmax; double ymin; double ymax; /* limits of enclosing frame are xmin-xstep/2, xmax+xstep/2 etc. */ } Raster; /* how to clear the data */ #define Clear(ARRAY,TYPE,VALUE) \ { unsigned int i; TYPE *p; \ for(i = 0, p = (TYPE *) (ARRAY).data; i < (ARRAY).length; i++, p++) \ *p = VALUE; } /* how to index a rectangular array stored sequentially in row-major order */ #define Entry(ARRAY,ROW,COL,TYPE) \ ((TYPE *)((ARRAY).data))[COL + (ROW) * ((ARRAY).ncol)] /* test for indices inside subrectangle */ #define Inside(ARRAY,ROW,COL) \ ( (ROW >= (ARRAY).rmin) && (ROW <= (ARRAY).rmax) && \ (COL >= (ARRAY).cmin) && (COL <= (ARRAY).cmax)) /* how to compute the position in R^2 corresponding to a raster entry */ #define Xpos(ARRAY,COL) \ ((ARRAY).x0 + (ARRAY).xstep * (COL - (ARRAY).cmin)) #define Ypos(ARRAY,ROW) \ ((ARRAY).y0 + (ARRAY).ystep * (ROW - (ARRAY).rmin)) #define Distance(X,Y,XX,YY) sqrt((X - XX)* (X - XX) + (Y - YY) * (Y - YY)) #define DistanceTo(X,Y,ARRAY,ROW,COL)\ Distance(X,Y,Xpos(ARRAY,COL),Ypos(ARRAY,ROW)) #define DistanceSquared(X,Y,XX,YY) ((X - XX)* (X - XX) + (Y - YY) * (Y - YY)) #define DistanceToSquared(X,Y,ARRAY,ROW,COL)\ DistanceSquared(X,Y,Xpos(ARRAY,COL),Ypos(ARRAY,ROW)) /* how to map a point (x,y) in R^2 to a raster entry */ /* (x,y) is guaranteed to lie in the rectangle bounded by the images of the entries (r,c), (r+1,c), (r,c+1), (r+1,c+1) where r = RowIndex(..) and c = ColIndex(..). */ #define RowIndex(ARRAY,Y) \ ((ARRAY).rmin + (int) floor(((Y) - (ARRAY).y0)/(ARRAY).ystep)) #define ColIndex(ARRAY,X) \ ((ARRAY).cmin + (int) floor(((X) - (ARRAY).x0)/(ARRAY).xstep)) spatstat.geom/src/connectgraph.c0000644000176200001440000000303514611065353016456 0ustar liggesusers/* connectgraph.c Connected component transform for a finite graph cocoGraph: connected component labels for a discrete graph specified by a list of edges $Revision: 1.1 $ $Date: 2023/07/18 03:28:58 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2023 Licence: GNU Public Licence >= 2 */ #include #include #include #include #include "yesno.h" void cocoGraph( /* inputs */ int *nv, /* number of graph vertices */ int *ne, /* number of edges */ int *ie, int *je, /* vectors of indices of ends of each edge */ /* output */ int *label, /* vector of component labels for each vertex */ /* Component label is lowest serial number of any vertex in the connected component */ int *status /* 0 if OK, 1 if overflow */ ) { int Nv, Ne, i, j, k, niter, labi, labj, changed; Nv = *nv; Ne = *ne; /* initialise labels */ for(k = 0; k < Nv; k++) label[k] = k; for(niter = 0; niter < Nv; niter++) { R_CheckUserInterrupt(); changed = NO; for(k = 0; k < Ne; k++) { i = ie[k]; j = je[k]; labi = label[i]; labj = label[j]; if(labi < labj) { label[j] = labi; changed = YES; } else if(labj < labi) { label[i] = labj; changed = YES; } } if(!changed) { /* algorithm has converged */ *status = 0; return; } } /* error exit */ *status = 1; return; } spatstat.geom/src/nearestpix.c0000644000176200001440000000513414611065353016167 0ustar liggesusers/* nearestpix.c Find the nearest TRUE pixel to a given (x,y) location Query locations (x,y) are transformed to coordinates in which the pixels are unit squares and the pixel centres start at (0,0) $Revision: 1.5 $ $Date: 2022/10/22 10:09:51 $ */ #include #include #include #include #include "chunkloop.h" #include "yesno.h" double sqrt(double x); /* fround is defined in Rmath.h */ void nearestvalidpixel( int *n, /* number of query points */ double *x, double *y, /* coordinates of query points (transformed) */ int *nr, int *nc, /* matrix dimensions */ double *aspect, /* aspect ratio (y/x) of original pixels */ int *z, /* entries of logical matrix */ int *nsearch, /* maximum permitted number of pixel steps on each axis */ /* OUTPUTS */ int *rr, int *cc /* row and column indices (-1) of nearest pixel centre */ ) { int maxchunk, N, Nrow, Ncol, maxrow, maxcol, maxsearch; double asp, xi, yi, ddd, ddi, huge, deltax, deltay; int i, row, col, zvalue; int rrr, ccc, rri, cci, startrow, endrow, startcol, endcol; N = *n; Nrow = *nr; Ncol = *nc; maxsearch = *nsearch; asp = *aspect; maxrow = Nrow - 1; maxcol = Ncol - 1; huge = sqrt(((double) Ncol) * ((double) Ncol) + asp * asp * ((double) Nrow) * ((double) Nrow)); OUTERCHUNKLOOP(i, N, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, N, maxchunk, 8196) { xi = x[i]; yi = y[i]; row = (int) fround(yi, (double) 0); col = (int) fround(xi, (double) 0); if(row < 0) row = 0; else if(row > maxrow) row = maxrow; if(col < 0) col = 0; else if(col > maxcol) col = maxcol; zvalue = z[row + Nrow * col]; if(zvalue != 0) { /* pixel is TRUE */ rr[i] = row; cc[i] = col; } else { /* initialise result to NA */ rri = cci = -1; ddi = huge; /* search neighbouring pixels */ startrow = imax2(row - maxsearch, 0); endrow = imin2(row + maxsearch, maxrow); startcol = imax2(col - maxsearch, 0); endcol = imin2(col + maxsearch, maxcol); if(startrow <= endrow && startcol <= endcol) { for(rrr = startrow; rrr <= endrow; rrr++) { for(ccc = startcol; ccc <= endcol; ccc++) { zvalue = z[rrr + Nrow * ccc]; if(zvalue != 0) { /* pixel is TRUE */ deltax = xi - (double) ccc; deltay = asp * (yi - (double) rrr); ddd = sqrt(deltax * deltax + deltay * deltay); if(ddd < ddi) { /* pixel is closer */ rri = rrr; cci = ccc; ddi = ddd; } } } } } /* save result */ rr[i] = rri; cc[i] = cci; } } } } spatstat.geom/src/nnMDdist.c0000644000176200001440000007670314611065353015537 0ustar liggesusers/* nnMDdist.c Nearest Neighbour Distances in m dimensions $Revision: 1.22 $ $Date: 2022/10/22 09:29:51 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Argument x is an m * n matrix with columns corresponding to points and rows corresponding to coordinates. Spatial dimension m must be > 1 THE FOLLOWING FUNCTIONS ASSUME THAT THE ROWS OF x ARE SORTED IN ASCENDING ORDER OF THE FIRST COLUMN nndMD Nearest neighbour distances nnwMD Nearest neighbours and their distances nnXwMD Nearest neighbour from one list to another nnXxMD Nearest neighbour from one list to another, with overlaps knndMD k-th nearest neighbour distances knnwMD k-th nearest neighbours and their distances knnXwMD k-th nearest neighbours from one list to another knnXxMD k-th nearest neighbours from one list to another, with overlaps */ #undef SPATSTAT_DEBUG #include #include #include #include "chunkloop.h" #include "yesno.h" double sqrt(double x); void nndMD( int *n, /* number of points */ int *m, /* spatial dimension */ double *x, /* coordinates (matrix m by n) */ double *nnd, /* output */ double *huge /* upper bound on pairwise distance */ ) { int npoints, mdimen, i, j, left, right, leftpos, rightpos, maxchunk; double d2, d2min, hu, hu2, xi0, dx0, dxj; double *xi; npoints = *n; mdimen = *m; xi = (double *) R_alloc((size_t) mdimen, sizeof(double)); /* dx = (double *) R_alloc((size_t) mdimen, sizeof(double)); */ hu = *huge; hu2 = hu * hu; OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { #ifdef SPATSTAT_DEBUG Rprintf("\ni=%d\n", i); #endif d2min = hu2; for(j = 0; j < mdimen; j++) xi[j] = x[i * mdimen + j]; xi0 = xi[0]; #ifdef SPATSTAT_DEBUG Rprintf("\n ("); for(j = 0; j < mdimen; j++) Rprintf("%lf, ", x[i * mdimen + j]); Rprintf(")\n"); #endif /* search backward */ if(i > 0) { for(left = i - 1; left >= 0; --left) { #ifdef SPATSTAT_DEBUG Rprintf("L=%d, d2min=%lf\n", left, d2min); #endif dx0 = xi0 - x[left * mdimen]; d2 = dx0 * dx0; if(d2 > d2min) break; leftpos = left * mdimen; for(j = 1; j < mdimen && d2 < d2min; j++) { dxj = xi[j] - x[leftpos + j]; d2 += dxj * dxj; } if (d2 < d2min) { d2min = d2; #ifdef SPATSTAT_DEBUG Rprintf("\tupdating d2min=%lf\n", d2min); #endif } } } /* search forward */ if(i < npoints - 1) { for(right = i + 1; right < npoints; ++right) { #ifdef SPATSTAT_DEBUG Rprintf("R=%d, d2min=%lf\n", right, d2min); #endif dx0 = x[right * mdimen] - xi0; d2 = dx0 * dx0; if(d2 > d2min) break; rightpos = right * mdimen; for(j = 1; j < mdimen && d2 < d2min; j++) { dxj = xi[j] - x[rightpos + j]; d2 += dxj * dxj; } if (d2 < d2min) { d2min = d2; #ifdef SPATSTAT_DEBUG Rprintf("\tupdating d2min=%lf\n", d2min); #endif } } } #ifdef SPATSTAT_DEBUG Rprintf("\n"); #endif nnd[i] = sqrt(d2min); } } } /* nnwMD: same as nndMD, but also returns id of nearest neighbour */ void nnwMD( int *n, /* number of points */ int *m, /* spatial dimension */ double *x, /* coordinates (matrix m by n) */ double *nnd, /* output n.n. distances */ int *nnwhich, /* output n.n. identifiers */ double *huge /* upper bound on pairwise distance */ ) { int npoints, mdimen, i, j, left, right, leftpos, rightpos, which, maxchunk; double d2, d2min, hu, hu2, xi0, dx0, dxj; double *xi; npoints = *n; mdimen = *m; xi = (double *) R_alloc((size_t) mdimen, sizeof(double)); /* dx = (double *) R_alloc((size_t) mdimen, sizeof(double)); */ hu = *huge; hu2 = hu * hu; OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { #ifdef SPATSTAT_DEBUG Rprintf("\ni=%d\n", i); #endif d2min = hu2; which = -1; for(j = 0; j < mdimen; j++) xi[j] = x[i * mdimen + j]; xi0 = xi[0]; /* search backward */ if(i > 0) { for(left = i - 1; left >= 0; --left) { #ifdef SPATSTAT_DEBUG Rprintf("L"); #endif dx0 = xi0 - x[left * mdimen]; d2 = dx0 * dx0; if(d2 > d2min) break; leftpos = left * mdimen; for(j = 1; j < mdimen && d2 < d2min; j++) { dxj = xi[j] - x[leftpos + j]; d2 += dxj * dxj; } if (d2 < d2min) { d2min = d2; which = left; } } } /* search forward */ if(i < npoints - 1) { for(right = i + 1; right < npoints; ++right) { #ifdef SPATSTAT_DEBUG Rprintf("R"); #endif dx0 = x[right * mdimen] - xi0; d2 = dx0 * dx0; if(d2 > d2min) break; rightpos = right * mdimen; for(j = 1; j < mdimen && d2 < d2min; j++) { dxj = xi[j] - x[rightpos + j]; d2 += dxj * dxj; } if (d2 < d2min) { d2min = d2; which = right; } } } #ifdef SPATSTAT_DEBUG Rprintf("\n"); #endif nnd[i] = sqrt(d2min); /* convert index to R convention */ nnwhich[i] = which + 1; } } } /* nnXwMD: for TWO point patterns X and Y, find the nearest neighbour (from each point of X to the nearest point of Y) returning both the distance and the identifier Requires both patterns to be sorted in order of increasing first coord */ void nnXwMD( int *m, /* spatial dimension */ int *n1, /* number of points in first pattern */ double *x1, /* coordinates of first pattern (matrix m by n1) */ int *n2, /* number of points in second pattern */ double *x2, /* coordinates of second pattern (matrix m by n2) */ double *nnd, /* output n.n. distances */ int *nnwhich, /* output n.n. identifiers */ double *huge /* upper bound on pairwise distance */ ) { int mdimen, npoints1, npoints2, i, ell, jleft, jright, jwhich, lastjwhich; double d2, d2min, x1i0, dx0, dxell, hu, hu2; double *x1i; int maxchunk; hu = *huge; hu2 = hu * hu; npoints1 = *n1; npoints2 = *n2; mdimen = *m; if(npoints1 == 0 || npoints2 == 0) return; x1i = (double *) R_alloc((size_t) mdimen, sizeof(double)); /* dx = (double *) R_alloc((size_t) mdimen, sizeof(double)); */ lastjwhich = 0; OUTERCHUNKLOOP(i, npoints1, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints1, maxchunk, 16384) { d2min = hu2; jwhich = -1; for(ell = 0; ell < mdimen; ell++) x1i[ell] = x1[i * mdimen + ell]; x1i0 = x1i[0]; /* search backward from previous nearest neighbour */ if(lastjwhich > 0) { for(jleft = lastjwhich - 1; jleft >= 0; --jleft) { dx0 = x1i0 - x2[jleft * mdimen]; d2 = dx0 * dx0; if(d2 > d2min) break; for(ell = 1; ell < mdimen && d2 < d2min; ell++) { dxell = x1i[ell] - x2[jleft * mdimen + ell]; d2 += dxell * dxell; } if (d2 < d2min) { d2min = d2; jwhich = jleft; } } } /* search forward from previous nearest neighbour */ if(lastjwhich < npoints2) { for(jright = lastjwhich; jright < npoints2; ++jright) { dx0 = x2[jright * mdimen] - x1i0; d2 = dx0 * dx0; if(d2 > d2min) break; for(ell = 1; ell < mdimen && d2 < d2min; ell++) { dxell = x1i[ell] - x2[jright * mdimen + ell]; d2 += dxell * dxell; } if (d2 < d2min) { d2min = d2; jwhich = jright; } } } nnd[i] = sqrt(d2min); nnwhich[i] = jwhich + 1; /* R convention */ lastjwhich = jwhich; } } } /* nnXxMD: similar to nnXwMD but allows X and Y to include common points (which are not to be counted as neighbours) Code numbers id1, id2 are attached to the patterns X and Y respectively, such that x1[i], y1[i] and x2[j], y2[j] are the same point iff id1[i] = id2[j]. Requires both patterns to be sorted in order of increasing first coord */ void nnXxMD( int *m, /* spatial dimension */ int *n1, /* number of points in first pattern */ double *x1, /* coordinates of first pattern (matrix m by n1) */ int *id1, /* code numbers for first pattern */ int *n2, /* number of points in second pattern */ double *x2, /* coordinates of second pattern (matrix m by n2) */ int *id2, /* code numbers for second pattern */ double *nnd, /* output n.n. distances */ int *nnwhich, /* output n.d. identifiers */ double *huge /* upper bound on pairwise distances */ ){ int mdimen, npoints1, npoints2, i, ell, jleft, jright, jwhich, lastjwhich, id1i; double d2, d2min, x1i0, dx0, dxell, hu, hu2; double *x1i; int maxchunk; hu = *huge; hu2 = hu * hu; npoints1 = *n1; npoints2 = *n2; mdimen = *m; if(npoints1 == 0 || npoints2 == 0) return; x1i = (double *) R_alloc((size_t) mdimen, sizeof(double)); /* dx = (double *) R_alloc((size_t) mdimen, sizeof(double)); */ lastjwhich = 0; OUTERCHUNKLOOP(i, npoints1, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints1, maxchunk, 16384) { d2min = hu2; jwhich = -1; id1i = id1[i]; for(ell = 0; ell < mdimen; ell++) x1i[ell] = x1[i * mdimen + ell]; x1i0 = x1i[0]; /* search backward from previous nearest neighbour */ if(lastjwhich > 0) { for(jleft = lastjwhich - 1; jleft >= 0; --jleft) { dx0 = x1i0 - x2[jleft * mdimen]; d2 = dx0 * dx0; if(d2 > d2min) break; /* do not compare identical points */ if(id2[jleft] != id1i) { for(ell = 1; ell < mdimen && d2 < d2min; ell++) { dxell = x1i[ell] - x2[jleft * mdimen + ell]; d2 += dxell * dxell; } if (d2 < d2min) { d2min = d2; jwhich = jleft; } } } } /* search forward from previous nearest neighbour */ if(lastjwhich < npoints2) { for(jright = lastjwhich; jright < npoints2; ++jright) { dx0 = x2[jright * mdimen] - x1i0; d2 = dx0 * dx0; if(d2 > d2min) break; /* do not compare identical points */ if(id2[jright] != id1i) { for(ell = 1; ell < mdimen && d2 < d2min; ell++) { dxell = x1i[ell] - x2[jright * mdimen + ell]; d2 += dxell * dxell; } if (d2 < d2min) { d2min = d2; jwhich = jright; } } } } nnd[i] = sqrt(d2min); nnwhich[i] = jwhich + 1L; /* R convention */ lastjwhich = jwhich; } } } /* knndMD nearest neighbours 1:kmax */ void knndMD( int *n, /* number of points */ int *m, /* spatial dimension */ int *kmax, /* maximum order of neighbours */ double *x, /* coordinates (matrix m by n) */ double *nnd, /* output n.n. distances (matrix kmax by n) */ double *huge /* prior upper bound on pairwise distances */ ) { int npoints, mdimen, nk, nk1, i, j, k, k1, left, right, unsorted, maxchunk; double d2, d2minK, xi0, dx0, dxj, hu, hu2, tmp; double *d2min, *xi; hu = *huge; hu2 = hu * hu; npoints = *n; mdimen = *m; nk = *kmax; nk1 = nk - 1; /* create space to store the squared k-th nearest neighbour distances for the current point */ d2min = (double *) R_alloc((size_t) nk, sizeof(double)); /* scratch space */ xi = (double *) R_alloc((size_t) mdimen, sizeof(double)); /* loop over points */ OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { #ifdef SPATSTAT_DEBUG Rprintf("\ni=%d\n", i); #endif /* initialise nn distances */ d2minK = hu2; for(k = 0; k < nk; k++) d2min[k] = hu2; for(j = 0; j < mdimen; j++) xi[j] = x[i* mdimen + j]; xi0 = xi[0]; #ifdef SPATSTAT_DEBUG Rprintf("\n ("); for(j = 0; j < mdimen; j++) Rprintf("%lf, ", xi[j]); Rprintf(")\n"); #endif /* search backward */ for(left = i - 1; left >= 0; --left) { dx0 = xi0 - x[left * mdimen]; d2 = dx0 * dx0; if(d2 > d2minK) break; #ifdef SPATSTAT_DEBUG Rprintf("L=%d\n", left); Rprintf("\t 0 "); #endif for(j = 1; j < mdimen && d2 < d2minK; j++) { #ifdef SPATSTAT_DEBUG Rprintf("%d ", j); #endif dxj = xi[j] - x[left * mdimen + j]; d2 += dxj * dxj; } #ifdef SPATSTAT_DEBUG Rprintf("\n\t d2=%lf\n", d2); #endif if (d2 < d2minK) { /* overwrite last entry */ #ifdef SPATSTAT_DEBUG Rprintf("\td2=%lf overwrites d2min[%d] = %lf\n", d2, nk1, d2min[nk1]); #endif d2min[nk1] = d2; /* bubble sort */ #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); #endif unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; } else { unsorted = NO; } } #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; } } /* search forward */ for(right = i + 1; right < npoints; ++right) { #ifdef SPATSTAT_DEBUG Rprintf("R=%d\n", right); Rprintf("\t 0 "); #endif dx0 = x[right * mdimen] - xi0; d2 = dx0 * dx0; if(d2 > d2minK) break; for(j = 1; j < mdimen && d2 < d2minK; j++) { #ifdef SPATSTAT_DEBUG Rprintf("%d ", j); #endif dxj = xi[j] - x[right * mdimen + j]; d2 += dxj * dxj; } #ifdef SPATSTAT_DEBUG Rprintf("\n\t d2=%lf\n", d2); #endif if (d2 < d2minK) { #ifdef SPATSTAT_DEBUG Rprintf("\td2=%lf overwrites d2min[%d] = %lf\n", d2, nk1, d2min[nk1]); #endif /* overwrite last entry */ d2min[nk1] = d2; /* bubble sort */ #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); #endif unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; } else { unsorted = NO; } } #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; } } #ifdef SPATSTAT_DEBUG Rprintf("\n"); #endif /* copy nn distances for point i to output matrix in ROW MAJOR order */ for(k = 0; k < nk; k++) { nnd[nk * i + k] = sqrt(d2min[k]); } } } } /* knnwMD nearest neighbours 1:kmax returns distances and indices */ void knnwMD( int *n, /* number of points */ int *m, /* spatial dimension */ int *kmax, /* maximum order of neighbours */ double *x, /* coordinates (matrix m by n) */ double *nnd, /* output n.n. distances (matrix kmax by n) */ int *nnwhich, /* output n.n. identifiers (matrix kmax by n) */ double *huge /* prior upper bound on pairwise distance */ ) { int npoints, mdimen, nk, nk1, i, j, k, k1, left, right, unsorted, itmp; double d2, d2minK, xi0, dx0, dxj, hu, hu2, tmp; double *d2min, *xi; int *which; int maxchunk; hu = *huge; hu2 = hu * hu; npoints = *n; mdimen = *m; nk = *kmax; nk1 = nk - 1; /* create space to store the nearest neighbour distances and indices for the current point */ d2min = (double *) R_alloc((size_t) nk, sizeof(double)); which = (int *) R_alloc((size_t) nk, sizeof(int)); /* scratch space */ xi = (double *) R_alloc((size_t) mdimen, sizeof(double)); /* loop over points */ OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { #ifdef SPATSTAT_DEBUG Rprintf("\ni=%d\n", i); #endif /* initialise nn distances */ d2minK = hu2; for(k = 0; k < nk; k++) { d2min[k] = hu2; which[k] = -1; } for(j = 0; j < mdimen; j++) xi[j] = x[i* mdimen + j]; xi0 = xi[0]; #ifdef SPATSTAT_DEBUG Rprintf("\n ("); for(j = 0; j < mdimen; j++) Rprintf("%lf, ", x[i * mdimen + j]); Rprintf(")\n"); #endif /* search backward */ for(left = i - 1; left >= 0; --left) { #ifdef SPATSTAT_DEBUG Rprintf("L=%d, d2minK=%lf\n", left, d2minK); Rprintf("\t 0 "); #endif dx0 = xi0 - x[left * mdimen]; d2 = dx0 * dx0; if(d2 > d2minK) break; for(j = 1; j < mdimen && d2 < d2minK; j++) { #ifdef SPATSTAT_DEBUG Rprintf("%d ", j); #endif dxj = xi[j] - x[left * mdimen + j]; d2 += dxj * dxj; } if (d2 < d2minK) { #ifdef SPATSTAT_DEBUG Rprintf("\td2=%lf overwrites d2min[%d] = %lf\n", d2, nk1, d2min[nk1]); #endif /* overwrite last entry */ d2min[nk1] = d2; which[nk1] = left; /* bubble sort */ #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; } else { unsorted = NO; } } #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; } } /* search forward */ for(right = i + 1; right < npoints; ++right) { #ifdef SPATSTAT_DEBUG Rprintf("R=%d, d2minK=%lf\n", right, d2minK); Rprintf("\t 0 "); #endif dx0 = x[right * mdimen] - xi0; d2 = dx0 * dx0; if(d2 > d2minK) break; for(j = 1; j < mdimen && d2 < d2minK; j++) { #ifdef SPATSTAT_DEBUG Rprintf("%d ", j); #endif dxj = xi[j] - x[right * mdimen + j]; d2 += dxj * dxj; } if (d2 < d2minK) { #ifdef SPATSTAT_DEBUG Rprintf("\td2=%lf overwrites d2min[%d] = %lf\n", d2, nk1, d2min[nk1]); #endif /* overwrite last entry */ d2min[nk1] = d2; which[nk1] = right; /* bubble sort */ #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; } else { unsorted = NO; } } #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; } } #ifdef SPATSTAT_DEBUG Rprintf("\n"); #endif /* copy nn distances for point i to output matrix in ROW MAJOR order */ for(k = 0; k < nk; k++) { nnd[nk * i + k] = sqrt(d2min[k]); /* convert index back to R convention */ nnwhich[nk * i + k] = which[k] + 1; } } } } /* -------------- TWO POINT PATTERNS, k-nearest ------------- */ /* knnXwMD nearest neighbours 1:kmax returns distances and indices */ void knnXwMD( int *m, /* spatial dimension */ int *n1, /* number of points in first pattern */ double *x1, /* coordinates of first pattern (matrix m by n1) */ int *n2, /* number of points in second pattern */ double *x2, /* coordinates of second pattern (matrix m by n2) */ int *kmax, /* maximum order of neighbours */ double *nnd, /* output n.n. distances (matrix kmax by n1) */ int *nnwhich, /* output n.n. identifiers (matrix kmax by n1) */ double *huge /* prior upper bound on pairwise distances */ ) { int mdimen, npoints1, npoints2, nk, nk1; int i, ell, jleft, jright, jwhich, lastjwhich; int k, k1, unsorted, itmp; double d2, d2minK, x1i0, dx0, dxell, hu, hu2, tmp; double *d2min, *x1i; int *which; int maxchunk; hu = *huge; hu2 = hu * hu; npoints1 = *n1; npoints2 = *n2; mdimen = *m; nk = *kmax; nk1 = nk - 1; /* create space to store the nearest neighbour distances and indices for the current point */ d2min = (double *) R_alloc((size_t) nk, sizeof(double)); which = (int *) R_alloc((size_t) nk, sizeof(int)); /* scratch space for current 'from' point coordinates */ x1i = (double *) R_alloc((size_t) mdimen, sizeof(double)); lastjwhich = 0; /* loop over 'from' points */ OUTERCHUNKLOOP(i, npoints1, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints1, maxchunk, 16384) { #ifdef SPATSTAT_DEBUG Rprintf("\ni=%d\n", i); #endif /* initialise nn distances */ d2minK = hu2; jwhich = -1; for(k = 0; k < nk; k++) { d2min[k] = hu2; which[k] = -1; } /* copy coordinates of current 'from' point */ for(ell = 0; ell < mdimen; ell++) x1i[ell] = x1[i* mdimen + ell]; x1i0 = x1i[0]; #ifdef SPATSTAT_DEBUG Rprintf("\n From ("); for(ell = 0; ell < mdimen; ell++) Rprintf("%lf, ", x1[i * mdimen + ell]); Rprintf(")\n"); #endif if(lastjwhich > 0) { /* search backward from previous nearest neighbour */ for(jleft = lastjwhich - 1; jleft >= 0; --jleft) { #ifdef SPATSTAT_DEBUG Rprintf("L=%d, d2minK=%lf\n", jleft, d2minK); Rprintf("\t 0 "); #endif dx0 = x1i0 - x2[jleft * mdimen]; d2 = dx0 * dx0; if(d2 > d2minK) break; for(ell = 1; ell < mdimen && d2 < d2minK; ell++) { #ifdef SPATSTAT_DEBUG Rprintf("%d ", ell); #endif dxell = x1i[ell] - x2[jleft * mdimen + ell]; d2 += dxell * dxell; } if (d2 < d2minK) { #ifdef SPATSTAT_DEBUG Rprintf("\td2=%lf overwrites d2min[%d] = %lf\n", d2, nk1, d2min[nk1]); #endif /* overwrite last entry */ d2min[nk1] = d2; which[nk1] = jleft; jwhich = jleft; /* bubble sort */ #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; } else { unsorted = NO; } } #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; } } } /* search forward */ if(lastjwhich < npoints2) { for(jright = lastjwhich; jright < npoints2; ++jright) { #ifdef SPATSTAT_DEBUG Rprintf("R=%d, d2minK=%lf\n", jright, d2minK); Rprintf("\t 0 "); #endif dx0 = x2[jright * mdimen] - x1i0; d2 = dx0 * dx0; if(d2 > d2minK) break; for(ell = 1; ell < mdimen && d2 < d2minK; ell++) { #ifdef SPATSTAT_DEBUG Rprintf("%d ", ell); #endif dxell = x1i[ell] - x2[jright * mdimen + ell]; d2 += dxell * dxell; } if (d2 < d2minK) { #ifdef SPATSTAT_DEBUG Rprintf("\td2=%lf overwrites d2min[%d] = %lf\n", d2, nk1, d2min[nk1]); #endif /* overwrite last entry */ d2min[nk1] = d2; which[nk1] = jright; jwhich = jright; /* bubble sort */ #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; } else { unsorted = NO; } } #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; } } } #ifdef SPATSTAT_DEBUG Rprintf("\n"); #endif /* copy nn distances for point i to output matrix in ROW MAJOR order */ for(k = 0; k < nk; k++) { nnd[nk * i + k] = sqrt(d2min[k]); /* convert index back to R convention */ nnwhich[nk * i + k] = which[k] + 1; } /* save index of last neighbour encountered */ lastjwhich = jwhich; } } } /* knnXxMD nearest neighbours 1:kmax with exclusions returns distances and indices */ void knnXxMD( int *m, /* spatial dimension */ int *n1, /* number of points in first pattern */ double *x1, /* coordinates of first pattern (matrix m by n1) */ int *id1, /* code numbers for first pattern */ int *n2, /* number of points in second pattern */ double *x2, /* coordinates of second pattern (matrix m by n2) */ int *id2, /* code numbers for second pattern */ int *kmax, /* maximum order of neighbours */ double *nnd, /* output n.n. distances (matrix kmax by n1) */ int *nnwhich, /* output n.n. identifiers (matrix kmax by n1) */ double *huge /* prior upper bound on pairwise distances */ ) { int mdimen, npoints1, npoints2, nk, nk1; int i, ell, jleft, jright, jwhich, lastjwhich; int k, k1, unsorted, itmp, id1i; double d2, d2minK, x1i0, dx0, dxell, hu, hu2, tmp; double *d2min, *x1i; int *which; int maxchunk; hu = *huge; hu2 = hu * hu; npoints1 = *n1; npoints2 = *n2; mdimen = *m; nk = *kmax; nk1 = nk - 1; /* create space to store the nearest neighbour distances and indices for the current point */ d2min = (double *) R_alloc((size_t) nk, sizeof(double)); which = (int *) R_alloc((size_t) nk, sizeof(int)); /* scratch space for current 'from' point coordinates */ x1i = (double *) R_alloc((size_t) mdimen, sizeof(double)); lastjwhich = 0; /* loop over 'from' points */ OUTERCHUNKLOOP(i, npoints1, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints1, maxchunk, 16384) { #ifdef SPATSTAT_DEBUG Rprintf("\ni=%d\n", i); #endif /* initialise nn distances */ d2minK = hu2; jwhich = -1; for(k = 0; k < nk; k++) { d2min[k] = hu2; which[k] = -1; } /* copy coordinates of current 'from' point */ for(ell = 0; ell < mdimen; ell++) x1i[ell] = x1[i* mdimen + ell]; x1i0 = x1i[0]; id1i = id1[i]; #ifdef SPATSTAT_DEBUG Rprintf("\n From ("); for(ell = 0; ell < mdimen; ell++) Rprintf("%lf, ", x1[i * mdimen + ell]); Rprintf(")\n"); #endif if(lastjwhich > 0) { /* search backward from previous nearest neighbour */ for(jleft = lastjwhich - 1; jleft >= 0; --jleft) { #ifdef SPATSTAT_DEBUG Rprintf("L=%d, d2minK=%lf\n", jleft, d2minK); Rprintf("\t 0 "); #endif dx0 = x1i0 - x2[jleft * mdimen]; d2 = dx0 * dx0; if(d2 > d2minK) break; /* don't compare identical points */ if(id2[jleft] != id1i) { for(ell = 1; ell < mdimen && d2 < d2minK; ell++) { #ifdef SPATSTAT_DEBUG Rprintf("%d ", ell); #endif dxell = x1i[ell] - x2[jleft * mdimen + ell]; d2 += dxell * dxell; } if (d2 < d2minK) { #ifdef SPATSTAT_DEBUG Rprintf("\td2=%lf overwrites d2min[%d] = %lf\n", d2, nk1, d2min[nk1]); #endif /* overwrite last entry */ d2min[nk1] = d2; which[nk1] = jleft; jwhich = jleft; /* bubble sort */ #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; } else { unsorted = NO; } } #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; } } } } /* search forward */ if(lastjwhich < npoints2) { for(jright = lastjwhich; jright < npoints2; ++jright) { #ifdef SPATSTAT_DEBUG Rprintf("R=%d, d2minK=%lf\n", jright, d2minK); Rprintf("\t 0 "); #endif dx0 = x2[jright * mdimen] - x1i0; d2 = dx0 * dx0; if(d2 > d2minK) break; /* don't compare identical points */ if(id2[jright] != id1i) { for(ell = 1; ell < mdimen && d2 < d2minK; ell++) { #ifdef SPATSTAT_DEBUG Rprintf("%d ", ell); #endif dxell = x1i[ell] - x2[jright * mdimen + ell]; d2 += dxell * dxell; } if (d2 < d2minK) { #ifdef SPATSTAT_DEBUG Rprintf("\td2=%lf overwrites d2min[%d] = %lf\n", d2, nk1, d2min[nk1]); #endif /* overwrite last entry */ d2min[nk1] = d2; which[nk1] = jright; jwhich = jright; /* bubble sort */ #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] before bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; } else { unsorted = NO; } } #ifdef SPATSTAT_DEBUG Rprintf("\td2min[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%lf, ", d2min[k]); Rprintf("\n"); Rprintf("\twhich[] after bubble sort:"); for(k = 0; k < nk; k++) Rprintf("%d, ", which[k]); Rprintf("\n"); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; } } } } #ifdef SPATSTAT_DEBUG Rprintf("\n"); #endif /* copy nn distances for point i to output matrix in ROW MAJOR order */ for(k = 0; k < nk; k++) { nnd[nk * i + k] = sqrt(d2min[k]); /* convert index back to R convention */ nnwhich[nk * i + k] = which[k] + 1; } /* save index of last neighbour encountered */ lastjwhich = jwhich; } } } spatstat.geom/src/loccum.c0000644000176200001440000000304214611065353015263 0ustar liggesusers#include #include #include #include "chunkloop.h" /* loccum.c $Revision: 1.2 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Compute local cumulative sums or products of weights locsum: f_i(t) = \sum_{j: j \neq i, ||x_j - x_i|| \le t} v(x_j) for a data point pattern {x_i} locxsum: f_u(t) = \sum_{||x_i - u|| \le t} v(x_i) for a grid of points {u} and a data point pattern {x_i} (also works if {u} is another point pattern) locprod: f_i(t) = \prod_{j: j \neq i, ||x_j - x_i|| \le t} v(x_j) for a data point pattern {x_i} locxprod: f_u(t) = \prod_{||x_i - u|| \le t} v(x_i) for a grid of points {u} and a data point pattern {x_i} (also works if {u} is another point pattern) Assumes point patterns are sorted in increasing order of x coordinate Uses C code template files : loccums.h, loccumx.h */ /* data-to-data */ #undef FNAME #undef NULVAL #undef INC #define FNAME locsum #define NULVAL 0.0 #define INC(A,B) A += B #include "loccums.h" #undef FNAME #undef NULVAL #undef INC #define FNAME locprod #define NULVAL 1.0 #define INC(A,B) A *= B #include "loccums.h" /* test-grid-to-data */ #undef FNAME #undef NULVAL #undef INC #define FNAME locxsum #define NULVAL 0.0 #define INC(A,B) A += B #include "loccumx.h" #undef FNAME #undef NULVAL #undef INC #define FNAME locxprod #define NULVAL 1.0 #define INC(A,B) A *= B #include "loccumx.h" spatstat.geom/src/bdrymask.c0000644000176200001440000000161614611065353015622 0ustar liggesusers/* bdrymask.c Boundary pixels of binary mask Copyright (C) Adrian Baddeley, Rolf Turner and Ege Rubak 2014 Licence: GPL >= 2 $Revision: 1.4 $ $Date: 2022/10/20 10:57:43 $ */ #include #include #include void bdrymask( /* inputs */ int *nx, int *ny, int *m, /* outputs */ int *b ) { int Nxcol, Nyrow, Nx1, Ny1; int i, j, mij; Nxcol = *nx; Nyrow = *ny; Nx1 = Nxcol - 1; Ny1 = Nyrow - 1; #define MAT(A,I,J) A[(I) + (J) * Nyrow] /* loop over pixels */ for(j = 0; j < Nxcol; j++) { R_CheckUserInterrupt(); for(i = 0; i < Nyrow; i++) { mij = MAT(m, i, j); if(i == 0 || i == Ny1 || j == 0 || j == Nx1) { MAT(b, i, j) = mij; } else if((mij != MAT(m, (i-1), j)) || (mij != MAT(m, (i+1), j)) || (mij != MAT(m, i, (j-1))) || (mij != MAT(m, i, (j+1)))) { MAT(b, i, j) = 1; } } } } spatstat.geom/src/nngrid.c0000644000176200001440000000334714611065353015272 0ustar liggesusers/* nngrid.c Nearest Neighbour Distances from a pixel grid to a point pattern Copyright (C) Adrian Baddeley, Jens Oehlschlaegel and Rolf Turner 2000-2013 Licence: GNU Public Licence >= 2 $Revision: 1.6 $ $Date: 2022/10/22 09:29:51 $ Function body definition is #included from nngrid.h THE FOLLOWING FUNCTIONS ASSUME THAT x IS SORTED IN ASCENDING ORDER */ #undef SPATSTAT_DEBUG #include #include #include #include "yesno.h" double sqrt(double x); /* THE FOLLOWING CODE ASSUMES THAT x IS SORTED IN ASCENDING ORDER */ #undef FNAME #undef DIST #undef WHICH /* nnGdw returns distances and indices */ #define FNAME nnGdw #define DIST #define WHICH #include "nngrid.h" #undef FNAME #undef DIST #undef WHICH /* nnGd returns distances only */ #define FNAME nnGd #define DIST #include "nngrid.h" #undef FNAME #undef DIST #undef WHICH /* nnGw returns indices only */ #define FNAME nnGw #define WHICH #include "nngrid.h" #undef FNAME #undef DIST #undef WHICH /* general interface */ void nnGinterface( /* pixel grid dimensions */ int *nx, double *x0, double *xstep, int *ny, double *y0, double *ystep, /* data points */ int *np, double *xp, double *yp, /* options */ int *wantdist, int *wantwhich, /* outputs */ double *nnd, int *nnwhich, /* upper bound on pairwise distance */ double *huge ) { int di, wh; di = (*wantdist != 0); wh = (*wantwhich != 0); if(di && wh) { nnGdw(nx, x0, xstep, ny, y0, ystep, np, xp, yp, nnd, nnwhich, huge); } else if(di) { nnGd(nx, x0, xstep, ny, y0, ystep, np, xp, yp, nnd, nnwhich, huge); } else if(wh) { nnGw(nx, x0, xstep, ny, y0, ystep, np, xp, yp, nnd, nnwhich, huge); } } spatstat.geom/src/rasterfilter.c0000644000176200001440000000240514611065353016511 0ustar liggesusers/* rasterfilter.c Apply linear filter to a raster image Copyright (C) Adrian Baddeley, Rolf Turner and Ege Rubak 2017 Licence: GPL >= 2 $Revision: 1.7 $ $Date: 2022/10/22 02:32:10 $ */ #include #include #include void raster3filter( int *nx, int *ny, /* raster dimensions */ double *a, /* input image */ double *w, /* 3x3 filter coefficients */ double *b /* output image */ ) { int Nxcol, Nyrow, Nx1, Ny1; int i, j; double value; Nxcol = *nx; Nyrow = *ny; Nx1 = Nxcol - 1; Ny1 = Nyrow - 1; #define A(I,J) a[(I) + (J) * Nyrow] #define B(I,J) b[(I) + (J) * Nyrow] #define WEIGHT(DI,DJ) w[((DI)+1) + ((DJ)+1)*3] #define FILTER(DI,DJ) WEIGHT(DI,DJ) * A(i+(DI), j+(DJ)) /* loop over pixels */ for(j = 0; j < Nxcol; j++) { R_CheckUserInterrupt(); for(i = 0; i < Nyrow; i++) { value = FILTER(0,0); if(j > 0) value += FILTER(0,-1); if(j < Nx1) value += FILTER(0, 1); if(i > 0) { if(j > 0) value += FILTER(-1,-1); value += FILTER(-1, 0); if(j < Nx1) value += FILTER(-1, 1); } if(i < Ny1) { if(j > 0) value += FILTER(1, -1); value += FILTER(1, 0); if(j < Nx1) value += FILTER(1, 1); } B(i,j) = value; } } } spatstat.geom/src/chunkloop.h0000644000176200001440000000161514611065353016014 0ustar liggesusers/* chunkloop.h Divide a loop into chunks Convenient for divide-and-recombine, and reducing calls to R_CheckUserInterrupt, etc. $Revision: 1.3 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #define OUTERCHUNKLOOP(IVAR, LOOPLENGTH, ICHUNK, CHUNKSIZE) \ IVAR = 0; \ ICHUNK = 0; \ while(IVAR < LOOPLENGTH) #define INNERCHUNKLOOP(IVAR, LOOPLENGTH, ICHUNK, CHUNKSIZE) \ ICHUNK += CHUNKSIZE; \ if(ICHUNK > LOOPLENGTH) ICHUNK = LOOPLENGTH; \ for(; IVAR < ICHUNK; IVAR++) #define XOUTERCHUNKLOOP(IVAR, ISTART, IEND, ICHUNK, CHUNKSIZE) \ IVAR = ISTART; \ ICHUNK = 0; \ while(IVAR <= IEND) #define XINNERCHUNKLOOP(IVAR, ISTART, IEND, ICHUNK, CHUNKSIZE) \ ICHUNK += CHUNKSIZE; \ if(ICHUNK > IEND) ICHUNK = IEND; \ for(; IVAR <= IEND; IVAR++) #define CHUNKLOOP_H spatstat.geom/src/dwpure.c0000644000176200001440000002320214611065353015307 0ustar liggesusers/* dwpure.c $Revision: 1.5 $ $Date: 2011/09/20 07:54:53 $ Code by Dominic Schuhmacher */ #include #include #include typedef struct State { int n1, n2; /* vectors of length n1 (rows) and n2 (cols) */ int *rowmass, *colmass; /* mass to be moved from row / to col */ int *rowlab, *collab; /* row and col labels (specify previous node (row for collab, col for rowlab)) */ int *rowflow, *colflow; /* second component of labels (specify flow through current node) */ int *rowsurplus, *colsurplus; /* the surplus in each row/col under the current flow */ int *dualu, *dualv; /* vectors of dual variables (u for rows, v for cols) */ int *rowhelper, *colhelper; /* helping vector to store intermediate results */ /* could be local in initcost at the moment */ /* n by n matrices */ int *d; /* matrix of costs */ int *flowmatrix; /* matrix of flows */ int *arcmatrix; /* matrix of arcs for restriced primal problem (1 if arc, 0 if no arc) should be unsigned char to save memory however need to workout problem with R_alloc first (see below) */ /* n*n vector */ int *collectvals; } State; #define COST(I,J,STATE,NVALUE) ((STATE)->d)[(NVALUE) * (J) + (I)] #define FLOW(I,J,STATE,NVALUE) ((STATE)->flowmatrix)[(NVALUE) * (J) + (I)] #define ARC(I,J,STATE,NVALUE) ((STATE)->arcmatrix)[(NVALUE) * (J) + (I)] #define MIN(A,B) ((A)<(B) ? (A) : (B)) int arraysum(int *a, int n); int arraymin(int *a, int n); void initvalues(State *state); void maxflow(State *state); void updateduals(State *state); void augmentflow(int startcol, State *state); /* ------------ The main function ----------------------------- */ void dwpure(int *d, int *rmass, int *cmass, int *numr, int *numc, int *flowmatrix) { int i,j; /* indices */ int n1,n2; unsigned char feasible = 0; /* boolean for main loop */ State state; /* inputs */ state.n1 = n1 = *numr; state.n2 = n2 = *numc; state.d = d; state.rowmass = rmass; state.colmass = cmass; /* scratch space */ state.rowlab = (int *) R_alloc((long) n1, sizeof(int)); state.collab = (int *) R_alloc((long) n2, sizeof(int)); state.rowflow = (int *) R_alloc((long) n1, sizeof(int)); state.colflow = (int *) R_alloc((long) n2, sizeof(int)); state.rowsurplus = (int *) R_alloc((long) n1, sizeof(int)); state.colsurplus = (int *) R_alloc((long) n2, sizeof(int)); state.dualu = (int *) R_alloc((long) n1, sizeof(int)); state.dualv = (int *) R_alloc((long) n2, sizeof(int)); state.rowhelper = (int *) R_alloc((long) n1, sizeof(int)); state.colhelper = (int *) R_alloc((long) n2, sizeof(int)); state.flowmatrix = (int *) R_alloc((long) (n1 * n2), sizeof(int)); state.arcmatrix = (int *) R_alloc((long) (n1 * n2), sizeof(int)); state.collectvals = (int *) R_alloc((long) (n1 * n2), sizeof(int)); for (i = 0; i < n1; ++i) { for (j = 0; j < n2; ++j) { state.flowmatrix[(n1)*(j) + i] = 0; state.arcmatrix[(n1)*(j) + i] = 0; state.collectvals[(n1)*(j) + i] = 0; } } for (i = 0; i < n1; ++i) { state.rowlab[i] = 0; state.rowflow[i] = 0; state.rowsurplus[i] = 0; state.dualu[i] = 0; state.rowhelper[i] = 0; } for (j = 0; j < n2; ++j) { state.collab[j] = 0; state.colflow[j] = 0; state.colsurplus[j] = 0; state.dualv[j] = 0; state.colhelper[j] = 0; } /* Initialize dual variables, arcmatrix, and surpluses */ initvalues(&state); /* For testing: print out cost matrix for (i = 0; i < n1; ++i) { for (j = 0; j < n2; ++j) { Rprintf("%d ", COST(i, j, &state, n1)); } Rprintf("\n"); } */ /* The main loop */ while(feasible == 0) { maxflow(&state); if (arraysum(state.rowsurplus, n1) > 0) { updateduals(&state); /* also updates arcmatrix */ } else { feasible = 1; } } /* "Return" the final flowmatrix */ for (i = 0; i < n1; i++) { for (j = 0; j < n2; j++) { flowmatrix[n1*j+i] = state.flowmatrix[n1*j+i]; } } } /* ------------ Functions called by dwpure_R ------------------------- */ /* Sum of integer array */ int arraysum(int *a, int n) { int i; int asum = 0; for (i = 0; i < n; i++) asum += a[i]; return(asum); } /* Minimal element of an integer array */ int arraymin(int *a, int n) { int i, amin; if (n < 1) return(-1); amin = a[0]; if (n > 1) for (i = 0; i < n; i++) if (a[i] < amin) amin = a[i]; return(amin); } /* Initialize cost matrix: subtract in each row its minimal entry (from all the entries in the row), then subtract in each column its minimal entry (from all the entries in the column) */ void initvalues(State *state) { int i,j,n1,n2; n1 = state->n1; n2 = state->n2; /* Initial surpluses; can I do this shorter? later on surpluses are updated in flow augmentation step */ for (i = 0; i < n1; i++) state->rowsurplus[i] = state->rowmass[i]; for (j = 0; j < n2; j++) state->colsurplus[j] = state->colmass[j]; for (i = 0; i < n1; i++) { for (j = 0; j < n2; j++) state->colhelper[j] = COST(i, j, state, n1); state->dualu[i] = arraymin(state->colhelper, n2); } for (j = 0; j < n2; j++) { for (i = 0; i < n1; i++) state->rowhelper[i] = COST(i, j, state, n1) - state->dualu[i]; state->dualv[j] = arraymin(state->rowhelper, n1); } for (i = 0; i < n1; i++) { for (j = 0; j < n2; j++) { if (COST(i, j, state, n1) == state->dualu[i] + state->dualv[j]) ARC(i, j, state, n1) = 1; else ARC(i, j, state, n1) = 0; } } } /* Maximize the flow on the (zeros of the) current cost matrix */ void maxflow(State *state) { int breakthrough; /* col. no. in which breakthrough occurs */ unsigned char labelfound = 1; /* 0 if no more labels can be found */ int i,j,n1,n2; n1 = state->n1; n2 = state->n2; while (labelfound == 1) { breakthrough = -1; /* initialize labels */ for (i = 0; i < n1; i++) { if (state->rowsurplus[i] > 0) { state->rowlab[i] = -5; state->rowflow[i] = state->rowsurplus[i]; } else { state->rowlab[i] = -1; /* setting rowflow to zero isn't necessary! */ } } for (j = 0; j < n2; j++) state->collab[j] = -1; /* setting colflow to zero isn't necessary! */ /* -1 means "no index", -5 means "source label" (rows only) */ while (labelfound == 1 && breakthrough == -1) { labelfound = 0; /* label unlabeled column j that permits flow from some labeled row i */ /* ("permits flow" means arcmatrix[i][j] = 1). Do so for every j */ for (i = 0; i < n1; i++) { if (state->rowlab[i] != -1) { for (j = 0; j < n2; j++) { if (ARC(i, j, state, n1) == 1 && state->collab[j] == -1) { state->collab[j] = i; state->colflow[j] = state->rowflow[i]; labelfound = 1; if (state->colsurplus[j] > 0 && breakthrough == -1) breakthrough = j; } } } } /* label unlabeled row i that already sends flow to some labeled col j */ /* ("already sends" means flowmatrix[i][j] > 0). Do so for every i */ for (j = 0; j < n2; j++) { if (state->collab[j] != -1) { for (i = 0; i < n1; i++) { if (FLOW(i, j, state, n1) > 0 && state->rowlab[i] == -1) { state->rowlab[i] = j; state->rowflow[i] = MIN(state->colflow[j],FLOW(i, j, state, n1)); labelfound = 1; } } } } } if (breakthrough != -1) augmentflow(breakthrough, state); } } /* Update the dual variables (called if solution of restricted primal is not feasible for the original problem): determine the minimum over the submatrix given by all labeled rows and unlabeled columns, and subtract it from all labeled rows and add it to all labeled columns. */ void updateduals(State *state) { int i,j,n1,n2,mini; int count = 0; n1 = state->n1; n2 = state->n2; for (i = 0; i < n1; i++) { for (j = 0; j < n2; j++) { if (state->rowlab[i] != -1 && state->collab[j] == -1) { state->collectvals[count] = COST(i, j, state, n1) - state->dualu[i] - state->dualv[j]; count++; } } } mini = arraymin(state->collectvals, count); for (i = 0; i < n1; i++) { if (state->rowlab[i] != -1) state->dualu[i] += mini; } for (j = 0; j < n2; j++){ if (state->collab[j] != -1) state->dualv[j] -= mini; } for (i = 0; i < n1; i++) { for (j = 0; j < n2; j++) { if (COST(i, j, state, n1) == state->dualu[i] + state->dualv[j]) ARC(i, j, state, n1) = 1; else ARC(i, j, state, n1) = 0; } } } /* Augment the flow on the graph given by arcmatrix (by aug) according to the row and column labels starting in column startcol */ /* Adjust the surpluses while we're at it (first row and last col have -aug) */ void augmentflow(int startcol, State *state) { int k,l,aug,n1; /* int i,j,k,l,aug,n1,n2; */ n1 = state->n1; l = startcol; aug = MIN(state->colflow[l], state->colsurplus[l]); state->colsurplus[l] -= aug; k = state->collab[l]; FLOW(k, l, state, n1) += aug; l = state->rowlab[k]; while (l != -5) { FLOW(k, l, state, n1) -= aug; k = state->collab[l]; FLOW(k, l, state, n1) += aug; l = state->rowlab[k]; } state->rowsurplus[k] -= aug; } spatstat.geom/src/poly2im.c0000644000176200001440000002026514611065353015402 0ustar liggesusers/* poly2im.c Conversion from (x,y) polygon to pixel image poly2imI pixel value = 1{pixel centre is inside polygon} poly2imA pixel value = area of intersection between pixel and polygon $Revision: 1.13 $ $Date: 2022/10/22 02:50:20 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef DEBUG #include #include #include #include "chunkloop.h" void poly2imI( /* polygon vertices, anticlockwise, CLOSED */ double *xp, double *yp, int *np, /* INTEGER raster points from (0,0) to (nx-1, ny-1) */ int *nx, int *ny, /* output matrix [ny, nx], byrow=FALSE, initialised to 0 */ int *out ) { int Np, Nx, Ny, Np1, maxchunk, mstart, mend; int j, k, m; double x0, y0, x1, y1, xleft, xright, yleft, yright; double dx, dy, y, slope, intercept; int jleft, jright, imax; int sign; Np = *np; Nx = *nx; Ny = *ny; /* Nxy = Nx * Ny; */ Np1 = Np - 1; /* run through polygon edges */ OUTERCHUNKLOOP(k, Np1, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(k, Np1, maxchunk, 8196) { x0 = xp[k]; y0 = yp[k]; x1 = xp[k+1]; y1 = yp[k+1]; if(x0 < x1) { xleft = x0; xright = x1; yleft = y0; yright = y1; sign = -1; } else { xleft = x1; xright = x0; yleft = y1; yright = y0; sign = +1; } /* determine relevant columns of pixels */ jleft = (int) ceil(xleft); jright = (int) floor(xright); if(jleft < Nx && jright >= 0 && jleft <= jright) { if(jleft < 0) { jleft = 0; } if(jright >= Nx) {jright = Nx - 1; } /* equation of edge */ dx = xright - xleft; dy = yright - yleft; slope = dy/dx; intercept = yleft - slope * xleft; /* visit relevant columns */ for(j = jleft; j <= jright; j++) { y = slope * ((double) j) + intercept; imax = (int) floor(y); if(imax >= Ny) imax = Ny-1; if(imax >= 0) { /* increment entries below edge in this column: out[i + j * Ny] += sign for 0 <= i <= imax */ mstart = j * Ny; mend = mstart + imax; for(m = mstart; m <= mend; m++) { out[m] += sign; } } } } } } } #define BELOW -1 #define INSIDE 0 #define ABOVE 1 void poly2imA( /* pixels are unit squares from (0,0) to (ncol,nrow) */ int *ncol, int *nrow, /* vectors of coordinates of polygon vertices */ double *xpoly, double *ypoly, int *npoly, /* output array [nrow, ncol] of pixel areas, byrow=TRUE, initialised to 0 */ double *out, int *status ) { double *xp, *yp; int nx, ny, nxy, np, np1, maxchunk; int i, j, k; double xcur, ycur, xnext, ynext, xleft, yleft, xright, yright; int sgn, jmin, jmax, imin, imax; double x0, y0, x1, y1, slope, yhi, ylo, area, xcut, xcutA, xcutB; int klo, khi; nx = *ncol; ny = *nrow; xp = xpoly; yp = ypoly; np = *npoly; *status = 0; /* initialise output array */ nxy = nx * ny; for(k = 0; k < nxy; k++) out[k] = 0; /* ............ loop over polygon edges ...................*/ np1 = np - 1; OUTERCHUNKLOOP(k, np1, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(k, np1, maxchunk, 8196) { xcur = xp[k]; ycur = yp[k]; xnext = xp[k+1]; ynext = yp[k+1]; #ifdef DEBUG Rprintf("\nEdge %d from (%lf, %lf) to (%lf, %lf) .........\n", k, xcur, ycur, xnext, ynext); #endif if(xcur != xnext) { /* vertical edges are ignored */ if(xcur < xnext) { #ifdef DEBUG Rprintf("negative sign\n"); #endif sgn = -1; xleft = xcur; yleft = ycur; xright = xnext; yright = ynext; } else { #ifdef DEBUG Rprintf("positive sign\n"); #endif sgn = 1; xleft = xnext; yleft = ynext; xright = xcur; yright = ycur; } /* we have now ensured xleft < xright */ slope = (yright - yleft)/(xright - xleft); /* Find relevant columns of pixels */ jmin = floor(xleft); jmin = (jmin < 0) ? 0 : jmin; jmax = ceil(xright); jmax = (jmax > nx - 1) ? nx - 1 : jmax; /* Find relevant rows of pixels */ imin = floor((yleft < yright) ? yleft : yright); imin = (imin < 0) ? 0 : imin; imax = ceil((yleft < yright) ? yright : yleft); imax = (imax > ny - 1) ? ny - 1 : imax; #ifdef DEBUG Rprintf( "imin=%d, imax=%d, jmin=%d, jmax=%d\n", imin, imax, jmin, jmax); #endif /* ........... loop over columns of pixels ..............*/ for(j = jmin; j <= jmax; j++) { #ifdef DEBUG Rprintf( "\t j=%d:\n", j); #endif /* Intersect trapezium with column of pixels */ if(xleft <= j+1 && xright >= j) { if(xleft >= j) { /* retain left corner */ #ifdef DEBUG Rprintf( "\tretain left corner\n"); #endif x0 = xleft; y0 = yleft; } else { /* trim left corner */ #ifdef DEBUG Rprintf( "\ttrim left corner\n"); #endif x0 = (double) j; y0 = yleft + slope * (x0 - xleft); } if(xright <= j+1) { /* retain right corner */ #ifdef DEBUG Rprintf( "\tretain right corner\n"); #endif x1 = xright; y1 = yright; } else { /* trim right corner */ #ifdef DEBUG Rprintf( "\ttrim right corner\n"); #endif x1 = (double) (j+1); y1 = yright + slope * (x1 - xright); } /* save min and max y */ if(y0 < y1) { #ifdef DEBUG Rprintf( "slope %lf > 0\n", slope); #endif ylo = y0; yhi = y1; } else { #ifdef DEBUG Rprintf( "slope %lf <= 0\n", slope); #endif ylo = y1; yhi = y0; } /* ............ loop over pixels within column ......... */ /* first part */ if(imin > 0) { for(i = 0; i < imin; i++) { #ifdef DEBUG Rprintf( "\ti=%d:\n", i); #endif /* The trimmed pixel [x0, x1] * [i, i+1] lies below the polygon edge. */ area = (x1 - x0); #ifdef DEBUG Rprintf( "\tIncrementing area by %lf\n", sgn * area); #endif out[i + ny * j] += sgn * area; } } /* second part */ for(i = imin; i <= imax; i++) { #ifdef DEBUG Rprintf( "\ti=%d:\n", i); #endif /* Compute area of intersection between trapezium and trimmed pixel [x0, x1] x [i, i+1] */ klo = (ylo <= i) ? BELOW : (ylo >= (i+1))? ABOVE: INSIDE; khi = (yhi <= i) ? BELOW : (yhi >= (i+1))? ABOVE: INSIDE; if(klo == ABOVE) { /* trapezium covers pixel */ #ifdef DEBUG Rprintf( "\t\ttrapezium covers pixel\n"); #endif area = (x1-x0); } else if(khi == BELOW) { #ifdef DEBUG Rprintf( "\t\tpixel avoids trapezium\n"); #endif /* pixel avoids trapezium */ area = 0.0; } else if(klo == INSIDE && khi == INSIDE) { /* polygon edge is inside pixel */ #ifdef DEBUG Rprintf( "\t\t polygon edge is inside pixel\n"); #endif area = (x1-x0) * ((ylo + yhi)/2.0 - i); } else if(klo == INSIDE && khi == ABOVE) { /* polygon edge crosses upper edge of pixel */ #ifdef DEBUG Rprintf( "\t\t polygon edge crosses upper edge of pixel\n"); #endif xcut = x0 + ((i+1) - y0)/slope; if(slope > 0) area = (xcut - x0) * ((y0 + (i+1))/2 - i) + (x1 - xcut); else area = (x1 - xcut) * ((y1 + (i+1))/2 - i) + (xcut - x0); } else if(klo == BELOW && khi == INSIDE) { /* polygon edge crosses lower edge of pixel */ #ifdef DEBUG Rprintf( "\t\t polygon edge crosses lower edge of pixel\n"); #endif xcut = x0 + (i - y0)/slope; if(slope > 0) area = (x1 - xcut) * ((y1 + i)/2 - i); else area = (xcut - x0) * ((y0 + i)/2 - i); } else if(klo == BELOW && khi == ABOVE) { /* polygon edge crosses upper and lower edges of pixel */ #ifdef DEBUG Rprintf( "\t\t polygon edge crosses upper and lower edges of pixel\n"); #endif xcutA = x0 + (i - y0)/slope; xcutB = x0 + ((i+1) - y0)/slope; if(slope > 0) area = (xcutB - xcutA)/2 + (x1 - xcutB); else area = (xcutB - x0) + (xcutA - xcutB)/2; } else { /* control should not pass to here */ *status = 1; return; } /* add contribution to area of pixel */ #ifdef DEBUG Rprintf( "\tIncrementing area by %lf\n", sgn * area); #endif out[i + ny * j] += sgn * area; } /* ............ end of loop over pixels within column ......... */ } } /* ........ end of loop over columns of pixels ...............*/ } } } /* ......... end of loop over polygon edges ...................*/ } spatstat.geom/src/pairloop.h0000644000176200001440000000344714611065353015644 0ustar liggesusers/* pairloop.h Generic code template for loop collecting contributions to point x_i from all points x_j such that ||x_i - x_j|| <= r cpp variables used: INITIAL_I code executed at start of 'i' loop CONTRIBUTE_IJ code executed to compute contribution from j to i COMMIT_I code executed to save total contribution to i C variables used: int i, j, n, maxchunk; double xi, yi, dx, dy, dx2, d2, r2max; double *x, *y; $Revision: 1.5 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #ifndef CHUNKLOOP_H #include "chunkloop.h" #endif #define PAIRLOOP(INITIAL_I, CONTRIBUTE_IJ, COMMIT_I) \ OUTERCHUNKLOOP(i, n, maxchunk, 65536) { \ R_CheckUserInterrupt(); \ INNERCHUNKLOOP(i, n, maxchunk, 65536) { \ \ xi = x[i]; \ yi = y[i]; \ \ INITIAL_I; \ \ if(i > 0) { \ for(j=i-1; j >= 0; j--) { \ dx = x[j] - xi; \ dx2 = dx * dx; \ if(dx2 > r2max) \ break; \ dy = y[j] - yi; \ d2 = dx2 + dy * dy; \ if(d2 <= r2max) { \ CONTRIBUTE_IJ; \ } \ } \ } \ \ if(i+1 < n) { \ for(j=i+1; j < n; j++) { \ dx = x[j] - xi; \ dx2 = dx * dx; \ if(dx2 > r2max) \ break; \ dy = y[j] - yi; \ d2 = dx2 + dy * dy; \ if(d2 <= r2max) { \ CONTRIBUTE_IJ; \ } \ } \ } \ COMMIT_I; \ } \ } spatstat.geom/src/distmapbin.c0000644000176200001440000000354514611065353016143 0ustar liggesusers/* distmapbin.c Distance transform of a discrete binary image (8-connected or 24-connected path metric) $Revision: 1.12 $ $Date: 2023/08/28 06:27:24 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2023 Licence: GNU Public Licence >= 2 */ #include #include "raster.h" #include void dist_to_bdry(Raster *d); void shape_raster(Raster *ras, void *data, double xmin, double ymin, double xmax, double ymax, int nrow, int ncol, int mrow, int mcol); /* define core algorithms, using template 'distmapbin.h' */ #define FNAME distmap_bin #define CONNECT 8 #include "distmapbin.h" #undef FNAME #undef CONNECT #define FNAME dist24map_bin #define CONNECT 24 #include "distmapbin.h" #undef FNAME #undef CONNECT /* R interface */ void distmapbin( int *connect, /* connectivity: 8 or 24 */ double *xmin, double *ymin, double *xmax, double *ymax, /* x, y dimensions */ int *nr, int *nc, /* raster dimensions EXCLUDING margin of 1 on each side */ int *inp, /* input: binary image */ double *distances, /* output: distance to nearest point */ double *boundary /* output: distance to boundary of rectangle */ /* all images must have identical dimensions including a margin of 1 on each side */ ) { Raster data, dist, bdist; void distmap_bin(Raster *in, Raster *dist); void dist24map_bin(Raster *in, Raster *dist); shape_raster( &data, (void *) inp, *xmin,*ymin,*xmax,*ymax, *nr+2, *nc+2, 1, 1); shape_raster( &dist, (void *) distances,*xmin,*ymin,*xmax,*ymax, *nr+2,*nc+2,1,1); shape_raster( &bdist, (void *) boundary, *xmin,*ymin,*xmax,*ymax, *nr+2,*nc+2,1,1); if(*connect != 24) { distmap_bin(&data, &dist); } else { dist24map_bin(&data, &dist); } dist_to_bdry(&bdist); } spatstat.geom/src/hasclose.c0000644000176200001440000000135614611065353015610 0ustar liggesusers/* hasclose.c $Revision: 1.4 $ $Date: 2016/11/29 05:09:25 $ Determine whether a point has a neighbour closer than 'r' Data must be ordered by increasing x coordinate */ #include #undef BUG #undef TORUS #undef ZCOORD #define CLOSEFUN hasXclose #define CROSSFUN hasXYclose #include "hasclose.h" #undef CLOSEFUN #undef CROSSFUN #define ZCOORD #define CLOSEFUN hasX3close #define CROSSFUN hasXY3close #include "hasclose.h" #undef CLOSEFUN #undef CROSSFUN #define TORUS #undef ZCOORD #define CLOSEFUN hasXpclose #define CROSSFUN hasXYpclose #include "hasclose.h" #undef CLOSEFUN #undef CROSSFUN #define ZCOORD #define CLOSEFUN hasX3pclose #define CROSSFUN hasXY3pclose #include "hasclose.h" #undef CLOSEFUN #undef CROSSFUN spatstat.geom/src/exactPdist.c0000644000176200001440000001033114611065353016110 0ustar liggesusers/* exactPdist.c `Pseudoexact' distance transform of a discrete binary image (the closest counterpart to `exactdist.c') $Revision: 1.15 $ $Date: 2022/10/22 09:29:51 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include #include "raster.h" void dist_to_bdry(Raster *d); void shape_raster(Raster *ras, void *data, double xmin, double ymin, double xmax, double ymax, int nrow, int ncol, int mrow, int mcol); void ps_exact_dt( Raster *in, /* input: binary image */ Raster *dist, /* output: exact distance to nearest point */ Raster *row, /* output: row index of closest point */ Raster *col /* output: column index of closest point */ /* rasters must have been dimensioned by shape_raster() and must all have identical dimensions and margins */ ){ int j,k; double d, x, y; int r, c; double dnew; double huge; /* double bdiag; */ /* initialise */ #define UNDEFINED -1 #define Is_Defined(I) (I >= 0) #define Is_Undefined(I) (I < 0) Clear(*row,int,UNDEFINED) Clear(*col,int,UNDEFINED) huge = 2.0 * DistanceSquared(dist->xmin,dist->ymin,dist->xmax,dist->ymax); Clear(*dist,double,huge) /* if input pixel is TRUE, set distance to 0 and make pixel point to itself */ for(j = in->rmin; j <= in->rmax; j++) for(k = in->cmin; k <= in->cmax; k++) if(Entry(*in, j, k, int) != 0) { Entry(*dist, j, k, double) = 0.0; Entry(*row, j, k, int) = j; Entry(*col, j, k, int) = k; } /* how to update the distance values */ #define GETVALUES(ROW,COL) \ x = Xpos(*in, COL); \ y = Ypos(*in, ROW); \ d = Entry(*dist,ROW,COL,double); #define COMPARE(ROW,COL,RR,CC) \ r = Entry(*row,RR,CC,int); \ c = Entry(*col,RR,CC,int); \ if(Is_Defined(r) && Is_Defined(c) \ && Entry(*dist,RR,CC,double) < d) { \ dnew = DistanceSquared(x, y, Xpos(*in,c), Ypos(*in,r)); \ if(dnew < d) { \ Entry(*row,ROW,COL,int) = r; \ Entry(*col,ROW,COL,int) = c; \ Entry(*dist,ROW,COL,double) = dnew; \ d = dnew; \ } \ } /* bound on diagonal step distance squared */ /* bdiag = (in->xstep * in->xstep + in->ystep * in->ystep); */ /* forward pass */ for(j = in->rmin; j <= in->rmax; j++) for(k = in->cmin; k <= in->cmax; k++) { GETVALUES(j, k) COMPARE(j,k, j-1,k-1) COMPARE(j,k, j-1, k) COMPARE(j,k, j-1,k+1) COMPARE(j,k, j, k-1) } /* backward pass */ for(j = in->rmax; j >= in->rmin; j--) for(k = in->cmax; k >= in->cmin; k--) { GETVALUES(j, k) COMPARE(j,k, j+1,k+1) COMPARE(j,k, j+1, k) COMPARE(j,k, j+1,k-1) COMPARE(j,k, j, k+1) } /* take square roots of distances^2 */ for(j = in->rmax; j >= in->rmin; j--) for(k = in->cmax; k >= in->cmin; k--) Entry(*dist,j,k,double) = sqrt(Entry(*dist,j,k,double)); } /* R interface */ void ps_exact_dt_R( double *xmin, double *ymin, double *xmax, double *ymax, /* x, y dimensions */ int *nr, int *nc, /* raster dimensions EXCLUDING margins */ int *mr, int *mc, /* margins */ int *inp, /* input: binary image */ double *distances, /* output: distance to nearest point */ int *rows, /* output: row of nearest point (start= 0) */ int *cols, /* output: column of nearest point (start = 0) */ double *boundary /* output: distance to boundary of rectangle */ /* all images must have identical dimensions including a margin of 1 on each side */ ) { Raster data, dist, row, col, bdist; int mrow, mcol, nrow, ncol; mrow = *mr; mcol = *mc; /* full dimensions */ nrow = *nr + 2 * mrow; ncol = *nc + 2 * mcol; shape_raster( &data, (void *) inp, *xmin,*ymin,*xmax,*ymax, nrow, ncol, mrow, mcol); shape_raster( &dist, (void *) distances, *xmin,*ymin,*xmax,*ymax, nrow, ncol, mrow, mcol); shape_raster( &row, (void *) rows, *xmin,*ymin,*xmax,*ymax, nrow, ncol, mrow, mcol); shape_raster( &col, (void *) cols, *xmin,*ymin,*xmax,*ymax, nrow, ncol, mrow, mcol); shape_raster( &bdist, (void *) boundary, *xmin,*ymin,*xmax,*ymax, nrow, ncol, mrow, mcol); ps_exact_dt(&data, &dist, &row, &col); dist_to_bdry(&bdist); } spatstat.geom/src/nndistance.c0000644000176200001440000001102614611065353016130 0ustar liggesusers/* nndistance.c Nearest Neighbour Distances between points Copyright (C) Adrian Baddeley, Jens Oehlschlaegel and Rolf Turner 2000-2012 Licence: GNU Public Licence >= 2 $Revision: 1.26 $ $Date: 2024/02/02 08:27:01 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2024 Licence: GNU Public Licence >= 2 THE FOLLOWING FUNCTIONS ASSUME THAT y IS SORTED IN ASCENDING ORDER SINGLE LIST: nndistsort Nearest neighbour distances nnwhichsort Nearest neighbours nnsort Nearest neighbours & distances ONE LIST TO ANOTHER LIST: nnXdist Nearest neighbour distance from one list to another nnXwhich Nearest neighbour ID from one list to another nnX Nearest neighbour ID & distance from one list to another ONE LIST TO ANOTHER OVERLAPPING LIST: nnXEdist Nearest neighbour distance from one list to another, overlapping nnXEwhich Nearest neighbour ID from one list to another, overlapping nnXE Nearest neighbour ID & distance */ #undef SPATSTAT_DEBUG #include #include #include #include "yesno.h" double sqrt(double x); /* THE FOLLOWING CODE ASSUMES THAT y IS SORTED IN ASCENDING ORDER */ /* ------------------- one point pattern X --------------------- */ /* nndistsort: nearest neighbour distances */ #undef FNAME #undef DIST #undef WHICH #define FNAME nndistsort #define DIST #include "nndist.h" /* nnwhichsort: id of nearest neighbour */ #undef FNAME #undef DIST #undef WHICH #define FNAME nnwhichsort #define WHICH #include "nndist.h" /* nnsort: distance & id of nearest neighbour */ #undef FNAME #undef DIST #undef WHICH #define FNAME nnsort #define DIST #define WHICH #include "nndist.h" /* --------------- two distinct point patterns X and Y ----------------- */ /* nnXdist: nearest neighbour distance (from each point of X to the nearest point of Y) */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME nnXdist #define DIST #include "nndistX.h" /* nnXwhich: nearest neighbour id */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME nnXwhich #define WHICH #include "nndistX.h" /* nnX: nearest neighbour distance and id */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME nnX #define DIST #define WHICH #include "nndistX.h" /* --------------- two point patterns X and Y with common points --------- */ /* Code numbers id1, id2 are attached to the patterns X and Y respectively, such that x1[i], y1[i] and x2[j], y2[j] are the same point iff id1[i] = id2[j]. */ /* nnXEdist: similar to nnXdist but allows X and Y to include common points (which are not to be counted as neighbours) */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME nnXEdist #define DIST #define EXCLUDE #include "nndistX.h" /* nnXEwhich: similar to nnXwhich but allows X and Y to include common points (which are not to be counted as neighbours) */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME nnXEwhich #define WHICH #define EXCLUDE #include "nndistX.h" /* nnXE: similar to nnX but allows X and Y to include common points (which are not to be counted as neighbours) */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME nnXE #define DIST #define WHICH #define EXCLUDE #include "nndistX.h" /* general interface */ void nnXinterface( /* first point pattern */ int *n1, double *x1, double *y1, int *id1, /* second point pattern */ int *n2, double *x2, double *y2, int *id2, /* options */ int *exclude, int *wantdist, int *wantwhich, /* outputs */ double *nnd, int *nnwhich, /* largest possible distance */ double *huge ) { /* defined above */ /* void nnX(), nnXdist(), nnXwhich(); */ /* void nnXE(), nnXEdist(), nnXEwhich(); */ int ex, di, wh; ex = (*exclude != 0); di = (*wantdist != 0); wh = (*wantwhich != 0); if(!ex) { if(di && wh) { nnX(n1, x1, y1, id1, n2, x2, y2, id2, nnd, nnwhich, huge); } else if(di) { nnXdist(n1, x1, y1, id1, n2, x2, y2, id2, nnd, nnwhich, huge); } else if(wh) { nnXwhich(n1, x1, y1, id1, n2, x2, y2, id2, nnd, nnwhich, huge); } } else { if(di && wh) { nnXE(n1, x1, y1, id1, n2, x2, y2, id2, nnd, nnwhich, huge); } else if(di) { nnXEdist(n1, x1, y1, id1, n2, x2, y2, id2, nnd, nnwhich, huge); } else if(wh) { nnXEwhich(n1, x1, y1, id1, n2, x2, y2, id2, nnd, nnwhich, huge); } } } spatstat.geom/src/scan.c0000644000176200001440000000411414611065353014726 0ustar liggesusers/* scan.c Scan transform $Revision: 1.6 $ $Date: 2022/10/22 09:29:51 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include #include #include "raster.h" void shape_raster(Raster *ras, void *data, double xmin, double ymin, double xmax, double ymax, int nrow, int ncol, int mrow, int mcol); void Cscantrans( double *x, double *y, /* data points */ int npt, double R, /* radius */ Raster *out /* scan image */ ) { int i,j,k,l,m; double d2, R2; int rmin, rmax, cmin, cmax, Rrow, Rcol, lmin, lmax, mmin, mmax; /* initialise raster */ Clear(*out,int,0); /* If the list of data points is empty, ... exit now */ if(npt == 0) return; R2 = R * R; cmin = out->cmin; cmax = out->cmax; rmin = out->rmin; rmax = out->rmax; /* disc size in rows/columns */ Rrow = (int) ceil(R/(out->ystep)); Rcol = (int) ceil(R/(out->xstep)); if(Rrow < 1) Rrow = 1; if(Rcol < 1) Rcol = 1; /* run through points */ for(i = 0; i < npt; i++) { j = RowIndex(*out,y[i]); k = ColIndex(*out,x[i]); lmin = j - Rrow; if(lmin < rmin) lmin = rmin; lmax = j + Rrow; if(lmax > rmax) lmax = rmax; mmin = k - Rcol; if(mmin < cmin) mmin = cmin; mmax = k + Rcol; if(mmax > cmax) mmax = cmax; for(l = lmin; l <= lmax; l++) { for(m = mmin; m <= mmax; m++) { d2 = DistanceToSquared(x[i],y[i],*out,l,m); if(d2 <= R2) Entry(*out,l,m,int) += 1; } } } } /* R interface */ void scantrans( double *x, double *y, /* input data points */ int *n, double *xmin, double *ymin, double *xmax, double *ymax, /* guaranteed bounding box */ int *nr, int *nc, /* desired raster dimensions */ double *R, /* radius */ /* output array */ int *counts /* number of R-close points */ ) { Raster out; int nrow, ncol, npoints; double r; nrow = *nr; ncol = *nc; npoints = *n; r = *R; shape_raster( &out, (void *) counts, *xmin,*ymin,*xmax,*ymax, nrow, ncol, 0, 0); Cscantrans(x, y, npoints, r, &out); } spatstat.geom/src/proto.h0000644000176200001440000002437214765164673015201 0ustar liggesusers#include #include /* Prototype declarations for all native routines in spatstat.geom package Automatically generated - do not edit! */ /* Functions invoked by .C */ void areadifs(double *, int *, double *, double *, int *, int *, double *); void areaBdif(double *, int *, double *, double *, int *, int *, double *, double *, double *, double *, double *); void xysegint(int *, double *, double *, double *, double *, int *, double *, double *, double *, double *, double *, double *, double *, double *, double *, int *); void Fclosepairs(int *, double *, double *, double *, int *, int *, int *, int *, double *, double *, double *, double *, double *, double *, double *, int *); void paircount(int *, double *, double *, double *, int *); void Fclosepairs(int *, double *, double *, double *, int *, int *, int *, int *, double *, double *, double *, double *, double *, double *, double *, int *); void crosscount(int *, double *, double *, int *, double *, double *, double *, int *); void Fcrosspairs(int *, double *, double *, int *, double *, double *, double *, int *, int *, int *, int *, double *, double *, double *, double *, double *, double *, double *, int *); void coco8dbl(double *, int *, int *); void coco4dbl(double *, int *, int *); void coco8int(int *, int *, int *); void coco4int(int *, int *, int *); void cocoGraph(int *, int *, int *, int *, int *, int *); void mdtPconv(double *, double *, double *, double *, int *, int *, int *, int *, int *, int *, double *, double *, int *, double *, int *, int *); void mdtPconv(double *, double *, double *, double *, int *, int *, int *, int *, int *, int *, double *, double *, int *, double *, int *, int *); void trigrafS(int *, int *, int *, int *, int *, int *, int *, int *, int *, int *); void trigraf(int *, int *, int *, int *, int *, int *, int *, int *, int *, int *); void Idist2dpath(int *, int *, int *, int *, int *, int *, int *); void discareapoly(int *, double *, double *, int *, double *, int *, double *, double *, double *, double *, double *, double *); void Ddist2dpath(int *, double *, int *, double *, double *, int *, int *); void D3pairdist(int *, double *, double *, double *, int *, double *); void D3pairPdist(int *, double *, double *, double *, double *, double *, double *, int *, double *); void nnd3D(int *, double *, double *, double *, double *, int *, double *); void knnd3D(int *, int *, double *, double *, double *, double *, int *, double *); void nnw3D(int *, double *, double *, double *, double *, int *, double *); void knnw3D(int *, int *, double *, double *, double *, double *, int *, double *); void D3crossdist(int *, double *, double *, double *, int *, double *, double *, double *, int *, double *); void D3crossPdist(int *, double *, double *, double *, int *, double *, double *, double *, double *, double *, double *, int *, double *); void Cpairdist(int *, double *, double *, int *, double *); void CpairPdist(int *, double *, double *, double *, double *, int *, double *); void Ccrossdist(int *, double *, double *, int *, double *, double *, int *, double *); void CcrossPdist(int *, double *, double *, int *, double *, double *, double *, double *, int *, double *); void nndMD(int *, int *, double *, double *, double *); void knndMD(int *, int *, int *, double *, double *, double *); void nnwMD(int *, int *, double *, double *, int *, double *); void knnwMD(int *, int *, int *, double *, double *, int *, double *); void nnXwMD(int *, int *, double *, int *, double *, double *, int *, double *); void nnXxMD(int *, int *, double *, int *, int *, double *, int *, double *, int *, double *); void knnXwMD(int *, int *, double *, int *, double *, int *, double *, int *, double *); void knnXxMD(int *, int *, double *, int *, int *, double *, int *, int *, double *, int *, double *); void distmapbin(int *, double *, double *, double *, double *, int *, int *, int *, double *, double *); void exact_dt_R(double *, double *, int *, double *, double *, double *, double *, int *, int *, int *, int *, double *, int *, double *); void ps_exact_dt_R(double *, double *, double *, double *, int *, int *, int *, int *, int *, double *, int *, int *, double *); void fardist2grid(int *, double *, double *, int *, double *, double *, int *, double *, double *, double *); void fardistgrid(int *, double *, double *, int *, double *, double *, int *, double *, double *, double *); void hasXclose(int *, double *, double *, double *, int *); void hasXpclose(int *, double *, double *, double *, double *, int *); void hasXYclose(int *, double *, double *, int *, double *, double *, double *, int *); void hasXYpclose(int *, double *, double *, int *, double *, double *, double *, double *, int *); void hasX3close(int *, double *, double *, double *, double *, int *); void hasX3pclose(int *, double *, double *, double *, double *, double *, int *); void hasXY3close(int *, double *, double *, double *, int *, double *, double *, double *, double *, int *); void hasXY3pclose(int *, double *, double *, double *, int *, double *, double *, double *, double *, double *, int *); void nearestvalidpixel(int *, double *, double *, int *, int *, double *, int *, int *, int *, int *); void mdtPOrect(double *, double *, double *, double *, int *, int *, int *, int *, int *, double *, int *, double *, int *, int *); void mdtPOrect(double *, double *, double *, double *, int *, int *, int *, int *, int *, double *, int *, double *, int *, int *); void minPnnd2(int *, double *, double *, double *, double *); void minnnd2(int *, double *, double *, double *, double *); void maxPnnd2(int *, double *, double *, double *, double *); void maxnnd2(int *, double *, double *, double *, double *); void nnX3Dinterface(int *, double *, double *, double *, int *, int *, double *, double *, double *, int *, int *, int *, int *, double *, int *, double *); void knnX3Dinterface(int *, double *, double *, double *, int *, int *, double *, double *, double *, int *, int *, int *, int *, int *, double *, int *, double *); void nnXinterface(int *, double *, double *, int *, int *, double *, double *, int *, int *, int *, int *, double *, int *, double *); void knnXinterface(int *, double *, double *, int *, int *, double *, double *, int *, int *, int *, int *, int *, double *, int *, double *); void nndistsort(int *, double *, double *, double *, double *); void knndsort(int *, int *, double *, double *, double *, double *); void nnwhichsort(int *, double *, double *, int *, double *); void knnwhich(int *, int *, double *, double *, int *, double *); void nnGinterface(int *, double *, double *, int *, double *, double *, int *, double *, double *, int *, int *, double *, int *, double *); void knnGinterface(int *, double *, double *, int *, double *, double *, int *, double *, double *, int *, int *, int *, double *, int *, double *); void poly2imA(int *, int *, double *, double *, int *, double *, int *); void xypsi(int *, double *, double *, double *, double *, double *, double *, double *, int *, int *); void Cxypolyselfint(int *, double *, double *, double *, double *, double *, double *, double *, double *, double *, int *); void auctionbf(int *, int *, int *, double *, double *, int *, double *); void dwpure(int *, int *, int *, int *, int *, int *); void auctionbf(int *, int *, int *, double *, double *, int *, double *); void dwpure(int *, int *, int *, int *, int *, int *); void dinfty_R(int *, int *, int *); void dwpure(int *, int *, int *, int *, int *, int *); void dwpure(int *, int *, int *, int *, int *, int *); void seg2pixI(int *, double *, double *, double *, double *, int *, int *, int *); void seg2pixL(int *, double *, double *, double *, double *, double *, double *, double *, int *, int *, double *); void seg2pixN(int *, double *, double *, double *, double *, double *, int *, int *, double *); void xysegint(int *, double *, double *, double *, double *, int *, double *, double *, double *, double *, double *, double *, double *, double *, double *, int *); void xysi(int *, double *, double *, double *, double *, int *, double *, double *, double *, double *, double *, int *); void xysiANY(int *, double *, double *, double *, double *, int *, double *, double *, double *, double *, double *, int *); void xysegXint(int *, double *, double *, double *, double *, double *, double *, double *, double *, double *, int *); void xysxi(int *, double *, double *, double *, double *, double *, int *); void Corput(int *, int *, double *); void raster3filter(int *, int *, double *, double *, double *); void uniqmapxy(int *, double *, double *, int *); void uniqmap2M(int *, double *, double *, int *, int *); void anydupxy(int *, double *, double *, int *); void poly2imI(double *, double *, int *, int *, int *, int *); void bdrymask(int *, int *, int *, int *); void discs2grid(int *, double *, double *, int *, double *, double *, int *, double *, double *, double *, int *); /* Functions invoked by .Call */ SEXP close3pairs(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP close3IJpairs(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP close3IJDpairs(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP cross3pairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP cross3IJpairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP cross3IJDpairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP closePpair(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP Vclosepairs(SEXP, SEXP, SEXP, SEXP); SEXP VcloseIJpairs(SEXP, SEXP, SEXP, SEXP); SEXP VcloseIJDpairs(SEXP, SEXP, SEXP, SEXP); SEXP altVclosepairs(SEXP, SEXP, SEXP, SEXP); SEXP altVcloseIJpairs(SEXP, SEXP, SEXP, SEXP); SEXP altVcloseIJDpairs(SEXP, SEXP, SEXP, SEXP); SEXP crossPpair(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP Vcrosspairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP VcrossIJpairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP VcrossIJDpairs(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP Vclosethresh(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP trioxgraph(SEXP, SEXP, SEXP, SEXP); SEXP triograph(SEXP, SEXP, SEXP); SEXP trigraph(SEXP, SEXP, SEXP); SEXP triDgraph(SEXP, SEXP, SEXP, SEXP); SEXP triDRgraph(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP graphVees(SEXP, SEXP, SEXP); SEXP Cxysegint(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); SEXP CxysegXint(SEXP, SEXP, SEXP, SEXP, SEXP); SEXP CxysegXint(SEXP, SEXP, SEXP, SEXP, SEXP); spatstat.geom/src/knnXdist.h0000644000176200001440000001543014611065353015614 0ustar liggesusers #if (1 == 0) /* knnXdist.h Code template for C functions supporting nncross for k-nearest neighbours (k > 1) THE FOLLOWING CODE ASSUMES THAT LISTS ARE SORTED IN ASCENDING ORDER OF y COORDINATE This code is #included multiple times in knndistance.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour EXCLUDE #defined if exclusion mechanism is used Either or both DIST and WHICH may be defined. When EXCLUDE is defined, code numbers id1, id2 are attached to the patterns X and Y respectively, such that x1[i], y1[i] and x2[j], y2[j] are the same point iff id1[i] = id2[j]. Copyright (C) Adrian Baddeley, Jens Oehlschlagel and Rolf Turner 2000-2013 Licence: GPL >= 2 $Revision: 1.13 $ $Date: 2022/10/23 00:23:50 $ */ #endif #undef USEJ #ifndef EXCLUDE #define USEJ #endif void FNAME( /* inputs */ int *n1, double *x1, double *y1, int *id1, int *n2, double *x2, double *y2, int *id2, int *kmax, /* outputs */ double *nnd, int *nnwhich, /* upper bound on pairwise distance */ double *huge /* some inputs + outputs are not used in all functions */ ) { int npoints1, npoints2, nk, nk1; int maxchunk, i, jleft, jright, lastjwhich, unsorted, k, k1; #ifdef USEJ int jwhich; #endif double d2, d2minK, x1i, y1i, dx, dy, dy2, hu, hu2, tmp; double *d2min; #ifdef WHICH int *which; int itmp; #endif #ifdef EXCLUDE int id1i; #endif #ifdef TRACER int kk; #endif npoints1 = *n1; npoints2 = *n2; nk = *kmax; nk1 = nk - 1; hu = *huge; hu2 = hu * hu; if(npoints1 == 0 || npoints2 == 0) return; lastjwhich = 0; /* remains unchanged if EXCLUDE is defined */ /* create space to store the nearest neighbour distances and indices for the current point */ d2min = (double *) R_alloc((size_t) nk, sizeof(double)); #ifdef WHICH which = (int *) R_alloc((size_t) nk, sizeof(int)); #endif /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < npoints1) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > npoints1) maxchunk = npoints1; for(; i < maxchunk; i++) { /* initialise nn distances and indices */ d2minK = hu2; #ifdef USEJ jwhich = -1; #endif for(k = 0; k < nk; k++) { d2min[k] = hu2; #ifdef WHICH which[k] = -1; #endif } x1i = x1[i]; y1i = y1[i]; #ifdef EXCLUDE id1i = id1[i]; #endif #ifdef TRACER Rprintf("i=%d : (%lf, %lf) ..................... \n", i, x1i, y1i); #endif if(lastjwhich < npoints2) { /* always true if EXCLUDE is defined */ #ifdef TRACER Rprintf("\tForward search from lastjwhich=%d:\n", lastjwhich); #endif /* search forward from previous nearest neighbour */ for(jright = lastjwhich; jright < npoints2; ++jright) { #ifdef TRACER Rprintf("\tjright=%d \t (%lf, %lf)\n", jright, x2[jright], y2[jright]); #endif dy = y2[jright] - y1i; dy2 = dy * dy; #ifdef TRACER Rprintf("\t\t dy2=%lf,\t d2minK=%lf\n", dy2, d2minK); #endif if(dy2 > d2minK) /* note that dy2 >= d2minK could break too early */ break; #ifdef EXCLUDE /* do not compare identical points */ if(id2[jright] != id1i) { #ifdef TRACER Rprintf("\t\t %d and %d are not identical\n", i, jright); #endif #endif dx = x2[jright] - x1i; d2 = dx * dx + dy2; #ifdef TRACER Rprintf("\t\t d2=%lf\n", d2); #endif if (d2 < d2minK) { /* overwrite last entry in list of neighbours */ #ifdef TRACER Rprintf("\t\t overwrite d2min[nk1]=%lf by d2=%lf\n", d2min[nk1], d2); #endif d2min[nk1] = d2; #ifdef USEJ jwhich = jright; #endif #ifdef WHICH which[nk1] = jright; #endif /* bubble sort */ unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } #ifdef TRACER Rprintf("\t\t sorted nn distances:\n"); for(kk = 0; kk < nk; kk++) Rprintf("\t\t d2min[%d] = %lf\n", kk, d2min[kk]); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; #ifdef TRACER Rprintf("\t\t d2minK=%lf\n", d2minK); #endif } #ifdef EXCLUDE } #endif } /* end forward search */ #ifdef TRACER Rprintf("\tEnd forward search\n"); #endif } if(lastjwhich > 0) { /* always false if EXCLUDE is defined */ #ifdef TRACER Rprintf("\tBackward search from lastjwhich=%d:\n", lastjwhich); #endif /* search backward from previous nearest neighbour */ for(jleft = lastjwhich - 1; jleft >= 0; --jleft) { #ifdef TRACER Rprintf("\tjleft=%d \t (%lf, %lf)\n", jleft, x2[jleft], y2[jleft]); #endif dy = y1i - y2[jleft]; dy2 = dy * dy; #ifdef TRACER Rprintf("\t\t dy2=%lf,\t d2minK=%lf\n", dy2, d2minK); #endif if(dy2 > d2minK) /* note that dy2 >= d2minK could break too early */ break; #ifdef EXCLUDE /* do not compare identical points */ if(id2[jleft] != id1i) { #ifdef TRACER Rprintf("\t\t %d and %d are not identical\n", i, jleft); #endif #endif dx = x2[jleft] - x1i; d2 = dx * dx + dy2; #ifdef TRACER Rprintf("\t\t d2=%lf\n", d2); #endif if (d2 < d2minK) { /* overwrite last entry in list of neighbours */ #ifdef TRACER Rprintf("\t\t overwrite d2min[nk1]=%lf by d2=%lf\n", d2min[nk1], d2); #endif d2min[nk1] = d2; #ifdef USEJ jwhich = jleft; #endif #ifdef WHICH which[nk1] = jleft; #endif /* bubble sort */ unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } #ifdef TRACER Rprintf("\t\t sorted nn distances:\n"); for(kk = 0; kk < nk; kk++) Rprintf("\t\t d2min[%d] = %lf\n", kk, d2min[kk]); #endif /* adjust maximum distance */ d2minK = d2min[nk1]; #ifdef TRACER Rprintf("\t\t d2minK=%lf\n", d2minK); #endif } #ifdef EXCLUDE } #endif } /* end backward search */ #ifdef TRACER Rprintf("\tEnd backward search\n"); #endif } /* copy nn distances for point i to output matrix in ROW MAJOR order */ for(k = 0; k < nk; k++) { #ifdef DIST nnd[nk * i + k] = sqrt(d2min[k]); #endif #ifdef WHICH nnwhich[nk * i + k] = which[k] + 1; /* R indexing */ #endif } #ifndef EXCLUDE /* save index of last neighbour encountered */ lastjwhich = jwhich; #endif /* end of loop over points i */ } } } spatstat.geom/src/minnnd.c0000644000176200001440000000122414611065353015264 0ustar liggesusers/* minnnd.c Minimum/Maximum Nearest Neighbour Distance Uses code templates in minnnd.h, maxnnd.h $Revision: 1.5 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include #include #include #undef IGNOREZERO #define FNAME minnnd2 #include "minnnd.h" #undef FNAME #define FNAME maxnnd2 #include "maxnnd.h" #undef FNAME /* min/max nearest neighbour distance ignoring zero distances */ #define IGNOREZERO #define FNAME minPnnd2 #include "minnnd.h" #undef FNAME #define FNAME maxPnnd2 #include "maxnnd.h" #undef FNAME spatstat.geom/src/periodic.c0000644000176200001440000001747514611065353015616 0ustar liggesusers/* periodic.c Routines for periodic edge correction Naive algorithms O(n^2) in time (but memory-efficient) which can easily be adapted to more general metrics. Coordinates are NOT assumed to be sorted $Revision: 1.7 $ $Date: 2022/10/22 09:29:51 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include #include #include #define OK 0 #define ERR_OVERFLOW 1 #define ERR_ALLOC 2 #define intRealloc(PTR, OLDLENGTH, NEWLENGTH) \ (int *) S_realloc((char *) PTR, NEWLENGTH, OLDLENGTH, sizeof(int)) #define dblRealloc(PTR, OLDLENGTH, NEWLENGTH) \ (double *) S_realloc((char *) PTR, NEWLENGTH, OLDLENGTH, sizeof(double)) double sqrt(double x); /* counterpart of 'closepairs' */ SEXP closePpair(SEXP xx, /* spatial coordinates */ SEXP yy, SEXP pp, /* period */ SEXP rr, /* max distance */ SEXP nguess) { double *x, *y; double xi, yi, rmax, r2max, dx, dy, d2, dxp, dyp; int n, k, kmax, kmaxold, maxchunk, i, j, m; double *period; double xperiod, yperiod; /* local storage */ int *iout, *jout; double *dout; /* R objects in return value */ SEXP Out, iOut, jOut, dOut; /* external storage pointers */ int *iOutP, *jOutP; double *dOutP; /* protect R objects from garbage collector */ PROTECT(xx = AS_NUMERIC(xx)); PROTECT(yy = AS_NUMERIC(yy)); PROTECT(pp = AS_NUMERIC(pp)); PROTECT(rr = AS_NUMERIC(rr)); PROTECT(nguess = AS_INTEGER(nguess)); /* that's 5 protected arguments */ #undef NINPUTS #define NINPUTS 5 /* Translate arguments from R to C */ x = NUMERIC_POINTER(xx); y = NUMERIC_POINTER(yy); n = LENGTH(xx); period = NUMERIC_POINTER(pp); xperiod = period[0]; yperiod = period[1]; rmax = *(NUMERIC_POINTER(rr)); r2max = rmax * rmax; kmax = *(INTEGER_POINTER(nguess)); k = 0; /* k is the next available storage location and also the current length of the list */ if(n > 0 && kmax > 0) { /* allocate space */ iout = (int *) R_alloc(kmax, sizeof(int)); jout = (int *) R_alloc(kmax, sizeof(int)); dout = (double *) R_alloc(kmax, sizeof(double)); /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < n) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > n) maxchunk = n; for(; i < maxchunk; i++) { xi = x[i]; yi = y[i]; if(i > 0) { /* scan backward */ for(j = i - 1; j >= 0; j--) { dx = x[j] - xi; if(dx < 0.0) dx = -dx; dxp = xperiod - dx; if(dxp < dx) dx = dxp; if(dx < rmax) { dy = y[j] - yi; if(dy < 0.0) dy = -dy; dyp = yperiod - dy; if(dyp < dy) dy = dyp; d2 = dx * dx + dy * dy; if(d2 <= r2max) { /* add this (i, j) pair to output */ if(k >= kmax) { /* overflow; allocate more space */ kmaxold = kmax; kmax = 2 * kmax; iout = intRealloc(iout, kmaxold, kmax); jout = intRealloc(jout, kmaxold, kmax); dout = dblRealloc(dout, kmaxold, kmax); } jout[k] = j + 1; /* R indexing */ iout[k] = i + 1; dout[k] = sqrt(d2); ++k; } } } } if(i + 1 < n) { /* scan forward */ for(j = i + 1; j < n; j++) { dx = x[j] - xi; if(dx < 0.0) dx = -dx; dxp = xperiod - dx; if(dxp < dx) dx = dxp; if(dx < rmax) { dy = y[j] - yi; if(dy < 0.0) dy = -dy; dyp = yperiod - dy; if(dyp < dy) dy = dyp; d2 = dx * dx + dy * dy; if(d2 <= r2max) { /* add this (i, j) pair to output */ if(k >= kmax) { /* overflow; allocate more space */ kmaxold = kmax; kmax = 2 * kmax; iout = intRealloc(iout, kmaxold, kmax); jout = intRealloc(jout, kmaxold, kmax); dout = dblRealloc(dout, kmaxold, kmax); } jout[k] = j + 1; /* R indexing */ iout[k] = i + 1; dout[k] = sqrt(d2); ++k; } } } } /* end of i loop */ } } } /* return a list of vectors */ PROTECT(Out = NEW_LIST(3)); PROTECT(iOut = NEW_INTEGER(k)); PROTECT(jOut = NEW_INTEGER(k)); PROTECT(dOut = NEW_NUMERIC(k)); #define NALLOCATED 4 /* copy results into return object */ if(k > 0) { iOutP = INTEGER_POINTER(iOut); jOutP = INTEGER_POINTER(jOut); dOutP = NUMERIC_POINTER(dOut); for(m = 0; m < k; m++) { iOutP[m] = iout[m]; jOutP[m] = jout[m]; dOutP[m] = dout[m]; } } SET_VECTOR_ELT(Out, 0, iOut); SET_VECTOR_ELT(Out, 1, jOut); SET_VECTOR_ELT(Out, 2, dOut); /* relinquish and return */ UNPROTECT(NINPUTS+NALLOCATED); return(Out); } /* ...........................................................*/ /* counterpart of 'crosspairs' */ SEXP crossPpair(SEXP xxA, /* spatial coordinates */ SEXP yyA, SEXP xxB, SEXP yyB, SEXP pp, /* period */ SEXP rr, /* max distance */ SEXP nguess) { double *xA, *yA, *xB, *yB; double xAi, yAi, rmax, r2max, dx, dy, d2, dxp, dyp; int nA, nB, k, kmax, kmaxold, maxchunk, i, j, m; double *period; double xperiod, yperiod; /* local storage */ int *iout, *jout; double *dout; /* R objects in return value */ SEXP Out, iOut, jOut, dOut; /* external storage pointers */ int *iOutP, *jOutP; double *dOutP; /* protect R objects from garbage collector */ PROTECT(xxA = AS_NUMERIC(xxA)); PROTECT(yyA = AS_NUMERIC(yyA)); PROTECT(xxB = AS_NUMERIC(xxB)); PROTECT(yyB = AS_NUMERIC(yyB)); PROTECT(pp = AS_NUMERIC(pp)); PROTECT(rr = AS_NUMERIC(rr)); PROTECT(nguess = AS_INTEGER(nguess)); /* that's 7 protected arguments */ #undef NINPUTS #define NINPUTS 7 /* Translate arguments from R to C */ xA = NUMERIC_POINTER(xxA); yA = NUMERIC_POINTER(yyA); xB = NUMERIC_POINTER(xxB); yB = NUMERIC_POINTER(yyB); nA = LENGTH(xxA); nB = LENGTH(xxB); period = NUMERIC_POINTER(pp); xperiod = period[0]; yperiod = period[1]; rmax = *(NUMERIC_POINTER(rr)); r2max = rmax * rmax; kmax = *(INTEGER_POINTER(nguess)); k = 0; /* k is the next available storage location and also the current length of the list */ if(nA > 0 && kmax > 0) { /* allocate space */ iout = (int *) R_alloc(kmax, sizeof(int)); jout = (int *) R_alloc(kmax, sizeof(int)); dout = (double *) R_alloc(kmax, sizeof(double)); /* loop over i in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < nA) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > nA) maxchunk = nA; for(; i < maxchunk; i++) { xAi = xA[i]; yAi = yA[i]; for(j = 0; j < nB; j++) { dx = xB[j] - xAi; if(dx < 0.0) dx = -dx; dxp = xperiod - dx; if(dxp < dx) dx = dxp; if(dx < rmax) { dy = yB[j] - yAi; if(dy < 0.0) dy = -dy; dyp = yperiod - dy; if(dyp < dy) dy = dyp; d2 = dx * dx + dy * dy; if(d2 <= r2max) { /* add this (i, j) pair to output */ if(k >= kmax) { /* overflow; allocate more space */ kmaxold = kmax; kmax = 2 * kmax; iout = intRealloc(iout, kmaxold, kmax); jout = intRealloc(jout, kmaxold, kmax); dout = dblRealloc(dout, kmaxold, kmax); } jout[k] = j + 1; /* R indexing */ iout[k] = i + 1; dout[k] = sqrt(d2); ++k; } } } } } } /* return a list of vectors */ PROTECT(Out = NEW_LIST(3)); PROTECT(iOut = NEW_INTEGER(k)); PROTECT(jOut = NEW_INTEGER(k)); PROTECT(dOut = NEW_NUMERIC(k)); #define NALLOCATED 4 /* copy results into return object */ if(k > 0) { iOutP = INTEGER_POINTER(iOut); jOutP = INTEGER_POINTER(jOut); dOutP = NUMERIC_POINTER(dOut); for(m = 0; m < k; m++) { iOutP[m] = iout[m]; jOutP[m] = jout[m]; dOutP[m] = dout[m]; } } SET_VECTOR_ELT(Out, 0, iOut); SET_VECTOR_ELT(Out, 1, jOut); SET_VECTOR_ELT(Out, 2, dOut); /* relinquish and return */ UNPROTECT(NINPUTS+NALLOCATED); return(Out); } spatstat.geom/src/init.c0000644000176200001440000001662014765164672014770 0ustar liggesusers /* Native symbol registration table for spatstat.geom package Automatically generated - do not edit this file! */ #include "proto.h" #include #include #include // for NULL #include /* See proto.h for declarations for the native routines registered below. */ static const R_CMethodDef CEntries[] = { {"anydupxy", (DL_FUNC) &anydupxy, 4}, {"areaBdif", (DL_FUNC) &areaBdif, 11}, {"areadifs", (DL_FUNC) &areadifs, 7}, {"auctionbf", (DL_FUNC) &auctionbf, 7}, {"bdrymask", (DL_FUNC) &bdrymask, 4}, {"Ccrossdist", (DL_FUNC) &Ccrossdist, 8}, {"CcrossPdist", (DL_FUNC) &CcrossPdist, 10}, {"coco4dbl", (DL_FUNC) &coco4dbl, 3}, {"coco4int", (DL_FUNC) &coco4int, 3}, {"coco8dbl", (DL_FUNC) &coco8dbl, 3}, {"coco8int", (DL_FUNC) &coco8int, 3}, {"cocoGraph", (DL_FUNC) &cocoGraph, 6}, {"Corput", (DL_FUNC) &Corput, 3}, {"Cpairdist", (DL_FUNC) &Cpairdist, 5}, {"CpairPdist", (DL_FUNC) &CpairPdist, 7}, {"crosscount", (DL_FUNC) &crosscount, 8}, {"Cxypolyselfint", (DL_FUNC) &Cxypolyselfint, 11}, {"D3crossdist", (DL_FUNC) &D3crossdist, 10}, {"D3crossPdist", (DL_FUNC) &D3crossPdist, 13}, {"D3pairdist", (DL_FUNC) &D3pairdist, 6}, {"D3pairPdist", (DL_FUNC) &D3pairPdist, 9}, {"Ddist2dpath", (DL_FUNC) &Ddist2dpath, 7}, {"dinfty_R", (DL_FUNC) &dinfty_R, 3}, {"discareapoly", (DL_FUNC) &discareapoly, 12}, {"discs2grid", (DL_FUNC) &discs2grid, 11}, {"distmapbin", (DL_FUNC) &distmapbin, 10}, {"dwpure", (DL_FUNC) &dwpure, 6}, {"exact_dt_R", (DL_FUNC) &exact_dt_R, 14}, {"fardist2grid", (DL_FUNC) &fardist2grid, 10}, {"fardistgrid", (DL_FUNC) &fardistgrid, 10}, {"Fclosepairs", (DL_FUNC) &Fclosepairs, 16}, {"Fcrosspairs", (DL_FUNC) &Fcrosspairs, 19}, {"hasX3close", (DL_FUNC) &hasX3close, 6}, {"hasX3pclose", (DL_FUNC) &hasX3pclose, 7}, {"hasXclose", (DL_FUNC) &hasXclose, 5}, {"hasXpclose", (DL_FUNC) &hasXpclose, 6}, {"hasXY3close", (DL_FUNC) &hasXY3close, 10}, {"hasXY3pclose", (DL_FUNC) &hasXY3pclose, 11}, {"hasXYclose", (DL_FUNC) &hasXYclose, 8}, {"hasXYpclose", (DL_FUNC) &hasXYpclose, 9}, {"Idist2dpath", (DL_FUNC) &Idist2dpath, 7}, {"knnd3D", (DL_FUNC) &knnd3D, 8}, {"knndMD", (DL_FUNC) &knndMD, 6}, {"knndsort", (DL_FUNC) &knndsort, 6}, {"knnGinterface", (DL_FUNC) &knnGinterface, 15}, {"knnw3D", (DL_FUNC) &knnw3D, 8}, {"knnwhich", (DL_FUNC) &knnwhich, 6}, {"knnwMD", (DL_FUNC) &knnwMD, 7}, {"knnX3Dinterface", (DL_FUNC) &knnX3Dinterface, 17}, {"knnXinterface", (DL_FUNC) &knnXinterface, 15}, {"knnXwMD", (DL_FUNC) &knnXwMD, 9}, {"knnXxMD", (DL_FUNC) &knnXxMD, 11}, {"maxnnd2", (DL_FUNC) &maxnnd2, 5}, {"maxPnnd2", (DL_FUNC) &maxPnnd2, 5}, {"mdtPconv", (DL_FUNC) &mdtPconv, 16}, {"mdtPOrect", (DL_FUNC) &mdtPOrect, 14}, {"minnnd2", (DL_FUNC) &minnnd2, 5}, {"minPnnd2", (DL_FUNC) &minPnnd2, 5}, {"nearestvalidpixel", (DL_FUNC) &nearestvalidpixel, 10}, {"nnd3D", (DL_FUNC) &nnd3D, 7}, {"nndistsort", (DL_FUNC) &nndistsort, 5}, {"nndMD", (DL_FUNC) &nndMD, 5}, {"nnGinterface", (DL_FUNC) &nnGinterface, 14}, {"nnw3D", (DL_FUNC) &nnw3D, 7}, {"nnwhichsort", (DL_FUNC) &nnwhichsort, 5}, {"nnwMD", (DL_FUNC) &nnwMD, 6}, {"nnX3Dinterface", (DL_FUNC) &nnX3Dinterface, 16}, {"nnXinterface", (DL_FUNC) &nnXinterface, 14}, {"nnXwMD", (DL_FUNC) &nnXwMD, 8}, {"nnXxMD", (DL_FUNC) &nnXxMD, 10}, {"paircount", (DL_FUNC) &paircount, 5}, {"poly2imA", (DL_FUNC) &poly2imA, 7}, {"poly2imI", (DL_FUNC) &poly2imI, 6}, {"ps_exact_dt_R", (DL_FUNC) &ps_exact_dt_R, 13}, {"raster3filter", (DL_FUNC) &raster3filter, 5}, {"seg2pixI", (DL_FUNC) &seg2pixI, 8}, {"seg2pixL", (DL_FUNC) &seg2pixL, 11}, {"seg2pixN", (DL_FUNC) &seg2pixN, 9}, {"trigraf", (DL_FUNC) &trigraf, 10}, {"trigrafS", (DL_FUNC) &trigrafS, 10}, {"uniqmap2M", (DL_FUNC) &uniqmap2M, 5}, {"uniqmapxy", (DL_FUNC) &uniqmapxy, 4}, {"xypsi", (DL_FUNC) &xypsi, 10}, {"xysegint", (DL_FUNC) &xysegint, 16}, {"xysegXint", (DL_FUNC) &xysegXint, 11}, {"xysi", (DL_FUNC) &xysi, 12}, {"xysiANY", (DL_FUNC) &xysiANY, 12}, {"xysxi", (DL_FUNC) &xysxi, 7}, {NULL, NULL, 0} }; static const R_CallMethodDef CallEntries[] = { {"altVcloseIJDpairs", (DL_FUNC) &altVcloseIJDpairs, 4}, {"altVcloseIJpairs", (DL_FUNC) &altVcloseIJpairs, 4}, {"altVclosepairs", (DL_FUNC) &altVclosepairs, 4}, {"close3IJDpairs", (DL_FUNC) &close3IJDpairs, 5}, {"close3IJpairs", (DL_FUNC) &close3IJpairs, 5}, {"close3pairs", (DL_FUNC) &close3pairs, 5}, {"closePpair", (DL_FUNC) &closePpair, 5}, {"cross3IJDpairs", (DL_FUNC) &cross3IJDpairs, 8}, {"cross3IJpairs", (DL_FUNC) &cross3IJpairs, 8}, {"cross3pairs", (DL_FUNC) &cross3pairs, 8}, {"crossPpair", (DL_FUNC) &crossPpair, 7}, {"Cxysegint", (DL_FUNC) &Cxysegint, 9}, {"CxysegXint", (DL_FUNC) &CxysegXint, 5}, {"graphVees", (DL_FUNC) &graphVees, 3}, {"triDgraph", (DL_FUNC) &triDgraph, 4}, {"triDRgraph", (DL_FUNC) &triDRgraph, 5}, {"trigraph", (DL_FUNC) &trigraph, 3}, {"triograph", (DL_FUNC) &triograph, 3}, {"trioxgraph", (DL_FUNC) &trioxgraph, 4}, {"VcloseIJDpairs", (DL_FUNC) &VcloseIJDpairs, 4}, {"VcloseIJpairs", (DL_FUNC) &VcloseIJpairs, 4}, {"Vclosepairs", (DL_FUNC) &Vclosepairs, 4}, {"Vclosethresh", (DL_FUNC) &Vclosethresh, 5}, {"VcrossIJDpairs", (DL_FUNC) &VcrossIJDpairs, 6}, {"VcrossIJpairs", (DL_FUNC) &VcrossIJpairs, 6}, {"Vcrosspairs", (DL_FUNC) &Vcrosspairs, 6}, {NULL, NULL, 0} }; void R_init_spatstat_geom(DllInfo *dll) { R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } spatstat.geom/src/close3pair.c0000644000176200001440000000335614611065353016055 0ustar liggesusers/* close3pair.c $Revision: 1.4 $ $Date: 2022/10/22 09:29:51 $ closepairs and crosspairs for 3D Assumes point pattern is sorted in increasing order of x coordinate Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include #include #include #define OK 0 #define ERR_OVERFLOW 1 #define ERR_ALLOC 2 #define intRealloc(PTR, OLDLENGTH, NEWLENGTH) \ (int *) S_realloc((char *) PTR, NEWLENGTH, OLDLENGTH, sizeof(int)) #define dblRealloc(PTR, OLDLENGTH, NEWLENGTH) \ (double *) S_realloc((char *) PTR, NEWLENGTH, OLDLENGTH, sizeof(double)) double sqrt(double x); /* ....... define functions, using closefuns.h ........*/ /* return only one of the pairs (i,j) and (j,i) */ #define SINGLE /* enable 3D code */ #define ZCOORD /* return i, j only */ #define CLOSEFUN close3IJpairs #define CROSSFUN cross3IJpairs #undef THRESH #undef COORDS #undef DIST #include "closefuns.h" #undef CLOSEFUN #undef CROSSFUN #undef THRESH #undef COORDS #undef DIST /* return i, j, d */ #define CLOSEFUN close3IJDpairs #define CROSSFUN cross3IJDpairs #undef THRESH #undef COORDS #define DIST #include "closefuns.h" #undef CLOSEFUN #undef CROSSFUN #undef THRESH #undef COORDS #undef DIST /* return i, j, xi, yi, zi, xj, yj, zj, dx, dy, dz, d */ #define CLOSEFUN close3pairs #define CROSSFUN cross3pairs #undef THRESH #define COORDS #define DIST #include "closefuns.h" #undef CLOSEFUN #undef CROSSFUN #undef THRESH #undef COORDS #undef DIST /* return i, j, t where t = 1{d < s} */ #define CLOSEFUN close3thresh #define CROSSFUN cross3thresh #define THRESH #undef COORDS #undef DIST #include "closefuns.h" #undef CLOSEFUN #undef CROSSFUN #undef THRESH #undef COORDS #undef DIST spatstat.geom/src/yesno.h0000644000176200001440000000011614611065353015142 0ustar liggesusers/* yesno.h */ #ifndef YES #define YES (0 == 0) #define NO (!YES) #endif spatstat.geom/src/uniquemap.c0000644000176200001440000000120714611065353016006 0ustar liggesusers/* uniquemap.c !! Assumes points are ordered by increasing x value !! $Revision: 1.2 $ $Date: 2019/05/21 07:36:34 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2019 Licence: GNU Public Licence >= 2 */ #include #undef ZCOORD #undef MARKED #undef QUITANY #define FUNNAME uniqmapxy #include "uniquemap.h" #undef FUNNAME #define QUITANY #define FUNNAME anydupxy #include "uniquemap.h" #undef FUNNAME #undef QUITANY #define MARKED #undef QUITANY #define FUNNAME uniqmap2M #include "uniquemap.h" #undef FUNNAME #define QUITANY #define FUNNAME anydup2M #include "uniquemap.h" #undef FUNNAME #undef QUITANY spatstat.geom/src/uniquemap.h0000644000176200001440000000403214611065353016012 0ustar liggesusers/* uniquemap.h Function definitions to be #included in uniquemap.c several times with different values of macros. !! Assumes points are ordered by increasing x value !! Assumes is included Macros used: FUNNAME name of function QUITANY return TRUE immediately if any duplicates are found ZCOORD if defined, coordinates are 3-dimensional MARKED if defined, points have INTEGER marks (tested for equality) $Revision: 1.7 $ $Date: 2022/03/27 02:00:34 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2019 Licence: GNU Public Licence >= 2 */ #ifdef ZCOORD #define SPACEDIM 3 #else #define SPACEDIM 2 #endif void FUNNAME(int *n, double *x, double *y, #ifdef ZCOORD double *z, #endif #ifdef MARKED int *marks, #endif #ifdef QUITANY int *anydup #else int *uniqmap #endif ) { double xi, yi, dx, dy, d2; #ifdef ZCOORD double zi, dz; #endif #ifdef MARKED int mi; #endif int N, maxchunk, i, j; /* loop in chunks of 2^16 */ N = *n; i = 0; maxchunk = 0; while(i < N) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > N) maxchunk = N; for(; i < maxchunk; i++) { xi = x[i]; yi = y[i]; #ifdef ZCOORD zi = z[i]; #endif #ifdef MARKED mi = marks[i]; #endif if(i + 1 < N) { #ifndef QUITANY if(uniqmap[i] == 0) { /* i.e. don't seek duplicates of a duplicate */ #endif /* scan forward */ for(j = i + 1; j < N; j++) { dx = x[j] - xi; if(dx > DBL_EPSILON) break; dy = y[j] - yi; d2 = dx * dx + dy * dy; #ifdef ZCOORD if(d2 <= 0.0) { dz = z[j] - zi; d2 = d2 + dz * dz; #endif if(d2 <= 0.0) { #ifdef MARKED if(marks[j] == mi) { #endif /* j is a duplicate of i */ #ifdef QUITANY *anydup = 1; /* i.e. TRUE */ return; #else uniqmap[j] = i + 1; /* R indexing */ #endif #ifdef MARKED } #endif } #ifdef ZCOORD } #endif } #ifndef QUITANY } #endif } } } } spatstat.geom/src/dist2dpath.h0000644000176200001440000001005114611065353016052 0ustar liggesusers/* Function body for dist2dpath.c Macros used: FNAME function name DTYPE declaration for distance values ('double' or 'int') FLOATY (DTYPE == 'double') $Revision: 1.5 $ $Date: 2022/10/20 10:57:43 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef DEBUG #define MATRIX(X,I,J) (X)[(J) + n * (I)] #define D(I,J) MATRIX(d, I, J) #define DPATH(I,J) MATRIX(dpath, I, J) #define ADJ(I,J) (MATRIX(adj, I, J) != 0) #define INFIN -1 #define FINITE(X) ((X) >= 0) void FNAME( int *nv, /* number of vertices */ DTYPE *d, /* matrix of edge lengths */ int *adj, /* 0/1 edge matrix of graph */ DTYPE *dpath, /* output - shortest path distance matrix */ DTYPE *tol, /* tolerance threshold (ignored in integer case) */ int *niter, /* number of iterations taken */ int *status /* status = 0 for convergence */ ) { int i, j, k, n, iter, maxiter, changed; DTYPE dij, dik, dkj, dikj; #ifdef FLOATY DTYPE eps, diff, maxdiff; #endif int totaledges, starti, nneighi, increm, pos; int *start, *nneigh, *indx; n = *nv; #ifdef FLOATY eps = *tol; #endif /* initialise and count edges */ *status = -1; totaledges = 0; for(i = 0; i < n; i++) { for(j = 0; j < n; j++) { DPATH(i, j) = (i == j) ? 0 : ((ADJ(i,j)) ? D(i, j) : INFIN); if((i != j) && ADJ(i,j)) ++totaledges; } } maxiter = 2 + ((totaledges > n) ? totaledges : n); /* store indices j for each edge (i,j) */ indx = (int *) R_alloc(totaledges, sizeof(int)); nneigh = (int *) R_alloc(n, sizeof(int)); start = (int *) R_alloc(n, sizeof(int)); pos = 0; for(i = 0; i < n; i++) { nneigh[i] = 0; start[i] = pos; #ifdef DEBUG Rprintf("Neighbours of %d:\n", i); #endif for(j = 0; j < n; j++) { if((i != j) && ADJ(i,j) && FINITE(D(i,j))) { #ifdef DEBUG Rprintf("\t%d\n", j); #endif ++(nneigh[i]); if(pos > totaledges) error("internal error: pos exceeded storage"); indx[pos] = j; ++pos; } } } /* run */ for(iter = 0; iter < maxiter; iter++) { changed = 0; #ifdef FLOATY maxdiff = 0; #endif #ifdef DEBUG Rprintf("--------- iteration %d ---------------\n", iter); #endif for(i = 0; i < n; i++) { R_CheckUserInterrupt(); nneighi = nneigh[i]; if(nneighi > 0) { /* run through neighbours k of i */ starti = start[i]; for(increm = 0, pos=starti; increm < nneighi; ++increm, ++pos) { k = indx[pos]; dik = DPATH(i,k); #ifdef DEBUG #ifdef FLOATY Rprintf("i=%d k=%d dik=%lf\n", i, k, dik); #else Rprintf("i=%d k=%d dik=%d\n", i, k, dik); #endif #endif /* now run through all other vertices j */ for(j = 0; j < n; j++) { if(j != i && j != k) { dij = DPATH(i,j); dkj = DPATH(k,j); if(FINITE(dkj)) { dikj = dik + dkj; #ifdef DEBUG #ifdef FLOATY Rprintf("considering %d -> (%d) -> %d,\t dij=%lf, dikj=%lf\n", i, k, j, dij, dikj); #else Rprintf("considering %d -> (%d) -> %d,\t dij=%d, dikj=%d\n", i, k, j, dij, dikj); #endif #endif if(!FINITE(dij) || dikj < dij) { #ifdef DEBUG #ifdef FLOATY Rprintf("updating i=%d j=%d via k=%d from %lf to %lf\n", i, j, k, dij, dikj); #else Rprintf("updating i=%d j=%d via k=%d from %d to %d\n", i, j, k, dij, dikj); #endif #endif DPATH(i,j) = DPATH(j,i) = dikj; changed = 1; #ifdef FLOATY diff = (FINITE(dij)) ? dij - dikj : dikj; if(diff > maxdiff) maxdiff = diff; #endif } } } } } } } if(changed == 0) { /* algorithm converged */ #ifdef DEBUG Rprintf("Algorithm converged\n"); #endif *status = 0; break; #ifdef FLOATY } else if(FINITE(maxdiff) && maxdiff < eps) { /* tolerance reached */ #ifdef DEBUG Rprintf("Algorithm terminated with maxdiff=%lf\n", maxdiff); #endif *status = 1; break; #endif } } #ifdef DEBUG Rprintf("Returning after %d iterations on %d vertices\n", iter, n); #endif *niter = iter; } #undef DEBUG #undef MATRIX #undef D #undef DPATH #undef ADJ #undef INFIN #undef FINITE spatstat.geom/src/distmapbin.h0000644000176200001440000000646114611065353016150 0ustar liggesusers/* distmapbin.h Distance transform of a discrete binary image Template for core algorithm This file is #included in 'distmapbin.c' several times with different values of the macros: FNAME Name of function CONNECT Connectivity (8 or 24) $Revision: 1.2 $ $Date: 2023/08/28 07:37:38 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2023 Licence: GNU Public Licence >= 2 */ #define DISTANCE(ROW, COL) Entry(*dist, ROW, COL, double) #define MASKTRUE(ROW, COL) (Entry(*in, ROW, COL, int) != 0) #define MASKFALSE(ROW, COL) (Entry(*in, ROW, COL, int) == 0) #define UPDATE(D, ROW, COL, STEP) \ dnew = STEP + DISTANCE(ROW, COL); \ if(D > dnew) D = dnew void FNAME( Raster *in, /* input: binary image */ Raster *dist /* output: distance to nearest point */ /* rasters must have been dimensioned by shape_raster() and must all have identical dimensions and margins */ ) { int j,k; double d, dnew; double xstep, ystep, diagstep, huge; int rmin, rmax, cmin, cmax; #if (CONNECT == 24) double LstepXXy, LstepYYx; #endif /* distances between neighbouring pixels */ xstep = in->xstep; ystep = in->ystep; if(xstep < 0) xstep = -xstep; if(ystep < 0) ystep = -ystep; diagstep = sqrt(xstep * xstep + ystep * ystep); #if (CONNECT == 24) LstepXXy = sqrt(4.0 * xstep * xstep + ystep * ystep); LstepYYx = sqrt(xstep * xstep + 4.0 * ystep * ystep); #endif /* effectively infinite distance */ huge = 2.0 * Distance(dist->xmin,dist->ymin,dist->xmax,dist->ymax); /* image boundaries */ rmin = in->rmin; rmax = in->rmax; cmin = in->cmin; cmax = in->cmax; /* initialise edges to boundary condition */ for(j = rmin-1; j <= rmax+1; j++) { DISTANCE(j, cmin-1) = (MASKTRUE(j, cmin-1)) ? 0.0 : huge; DISTANCE(j, cmax+1) = (MASKTRUE(j, cmax+1)) ? 0.0 : huge; } for(k = cmin-1; k <= cmax+1; k++) { DISTANCE(rmin-1, k) = (MASKTRUE(rmin-1, k)) ? 0.0 : huge; DISTANCE(rmax+1, k) = (MASKTRUE(rmax+1, k)) ? 0.0 : huge; } /* forward pass */ for(j = rmin; j <= rmax; j++) { R_CheckUserInterrupt(); for(k = cmin; k <= cmax; k++) { if(MASKTRUE(j, k)) d = DISTANCE(j, k) = 0.0; else { d = huge; UPDATE(d, j-1, k-1, diagstep); UPDATE(d, j-1, k, ystep); UPDATE(d, j-1, k+1, diagstep); UPDATE(d, j, k-1, xstep); #if (CONNECT == 24) if(j > rmin) { UPDATE(d, j-2, k-1, LstepYYx); UPDATE(d, j-2, k+1, LstepYYx); } if(k > cmin) { UPDATE(d, j-1, k-2, LstepXXy); } if(k < cmax) { UPDATE(d, j-1, k+2, LstepXXy); } #endif DISTANCE(j,k) = d; } } } /* backward pass */ for(j = rmax; j >= rmin; j--) { R_CheckUserInterrupt(); for(k = cmax; k >= cmin; k--) { if(MASKFALSE(j,k)) { d = DISTANCE(j,k); UPDATE(d, j+1, k+1, diagstep); UPDATE(d, j+1, k, ystep); UPDATE(d, j+1, k-1, diagstep); UPDATE(d, j, k+1, xstep); #if (CONNECT == 24) if(j < rmax) { UPDATE(d, j+2, k-1, LstepYYx); UPDATE(d, j+2, k+1, LstepYYx); } if(k > cmin) { UPDATE(d, j+1, k-2, LstepXXy); } if(k < cmax) { UPDATE(d, j+1, k+2, LstepXXy); } #endif DISTANCE(j,k) = d; } } } } #undef DISTANCE #undef MASKTRUE #undef MASKFALSE #undef UPDATE spatstat.geom/src/nn3Ddist.c0000644000176200001440000001754014611065353015477 0ustar liggesusers/* nn3Ddist.c Nearest Neighbour Distances in 3D $Revision: 1.15 $ $Date: 2022/10/22 09:29:51 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 THE FOLLOWING FUNCTIONS ASSUME THAT z IS SORTED IN ASCENDING ORDER nnd3D Nearest neighbour distances nnw3D Nearest neighbours (id) nndw3D Nearest neighbours (id) and distances nnXdw3D Nearest neighbour from one list to another nnXEdw3D Nearest neighbour from one list to another, with overlaps knnd3D k-th nearest neighbour distances knnw3D k-th nearest neighbours (id) knndw3D k-th nearest neighbours (id) and distances */ #undef SPATSTAT_DEBUG #include #include #include #include "chunkloop.h" #include "yesno.h" double sqrt(double x); /* >>>>>>>>>>>> NEAREST NEIGHBOURS <<<<<<<<<<<<<<<<<<<<<<<< */ /* .......... Single point pattern ...............................*/ #undef FNAME #undef DIST #undef WHICH /* nnd3D: returns nn distance */ #define FNAME nnd3D #define DIST #include "nn3Ddist.h" #undef FNAME #undef DIST #undef WHICH /* nnw3D: returns id of nearest neighbour */ #define FNAME nnw3D #define WHICH #include "nn3Ddist.h" #undef FNAME #undef DIST #undef WHICH /* nndw3D: returns nn distance .and. id of nearest neighbour */ #define FNAME nndw3D #define DIST #define WHICH #include "nn3Ddist.h" #undef FNAME #undef DIST #undef WHICH /* .......... Two point patterns ...............................*/ /* nnXdw3D: for TWO point patterns X and Y, find the nearest neighbour (from each point of X to the nearest point of Y) returning both the distance and the identifier Requires both patterns to be sorted in order of increasing z coord */ #define FNAME nnXdw3D #define DIST #define WHICH #undef EXCLUDE #include "nn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* nnXd3D: returns distance only */ #define FNAME nnXd3D #define DIST #undef EXCLUDE #include "nn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* nnXw3D: returns identifier only */ #define FNAME nnXw3D #define WHICH #undef EXCLUDE #include "nn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* .......... Two point patterns with exclusion ........................*/ /* nnXEdw3D: similar to nnXdw3D but allows X and Y to include common points (which are not to be counted as neighbours) Code numbers id1, id2 are attached to the patterns X and Y respectively, such that x1[i], y1[i] and x2[j], y2[j] are the same point iff id1[i] = id2[j]. Requires both patterns to be sorted in order of increasing z coord */ #define FNAME nnXEdw3D #define DIST #define WHICH #define EXCLUDE #include "nn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* nnXEd3D: returns distances only */ #define FNAME nnXEd3D #define DIST #define EXCLUDE #include "nn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* nnXEw3D: returns identifiers only */ #define FNAME nnXEw3D #define WHICH #define EXCLUDE #include "nn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* COMMON INTERFACE */ /* common interface for nearest neighbours of two point patterns */ void nnX3Dinterface( /* inputs */ int *n1, double *x1, double *y1, double *z1, int *id1, int *n2, double *x2, double *y2, double *z2, int *id2, /* options */ int *exclude, int *wantdist, int *wantwhich, /* outputs */ double *nnd, int *nnwhich, /* upper bound on pairwise distance */ double *huge ) { int ex, di, wh; ex = (*exclude != 0); di = (*wantdist != 0); wh = (*wantwhich != 0); if(!ex) { if(di && wh) { nnXdw3D(n1, x1, y1, z1, id1, n2, x2, y2, z2, id2, nnd, nnwhich, huge); } else if(di) { nnXd3D(n1, x1, y1, z1, id1, n2, x2, y2, z2, id2, nnd, nnwhich, huge); } else if(wh) { nnXw3D(n1, x1, y1, z1, id1, n2, x2, y2, z2, id2, nnd, nnwhich, huge); } } else { if(di && wh) { nnXEdw3D(n1, x1, y1, z1, id1, n2, x2, y2, z2, id2, nnd, nnwhich, huge); } else if(di) { nnXEd3D(n1, x1, y1, z1, id1, n2, x2, y2, z2, id2, nnd, nnwhich, huge); } else if(wh) { nnXEw3D(n1, x1, y1, z1, id1, n2, x2, y2, z2, id2, nnd, nnwhich, huge); } } } /* >>>>>>>>>>>>>> K-th NEAREST NEIGHBOURS <<<<<<<<<<<<<<<<<<<<< */ /* .......... Single point pattern ...............................*/ /* .......... k-th nearest neighbours ...............................*/ /* knnd3D nearest neighbour distances 1:kmax */ #define FNAME knnd3D #define DIST #include "knn3Ddist.h" #undef FNAME #undef DIST #undef WHICH /* knnw3D nearest neighbour indices 1:kmax */ #define FNAME knnw3D #define WHICH #include "knn3Ddist.h" #undef FNAME #undef DIST #undef WHICH /* knndw3D nearest neighbours 1:kmax returns distances and indices */ #define FNAME knndw3D #define DIST #define WHICH #include "knn3Ddist.h" #undef FNAME #undef DIST #undef WHICH /* .......... Two point patterns ...............................*/ /* .......... k-th nearest neighbours ...............................*/ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* knnXdw3D nearest neighbours 1:kmax between two point patterns returns distances and indices */ #define FNAME knnXdw3D #define DIST #define WHICH #include "knn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* knnXd3D nearest neighbours 1:kmax between two point patterns returns distances */ #define FNAME knnXd3D #define DIST #include "knn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* knnXw3D nearest neighbours 1:kmax between two point patterns returns indices */ #define FNAME knnXw3D #define WHICH #include "knn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* .......... Two point patterns with exclusion ..........................*/ /* .......... k-th nearest neighbours ...............................*/ /* knnXEdw3D nearest neighbours 1:kmax between two point patterns with exclusion returns distances and indices */ #define FNAME knnXEdw3D #define DIST #define WHICH #define EXCLUDE #include "knn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* knnXEd3D nearest neighbours 1:kmax between two point patterns with exclusion returns distances */ #define FNAME knnXEd3D #define DIST #define EXCLUDE #include "knn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* knnXEw3D nearest neighbours 1:kmax between two point patterns with exclusion returns indices */ #define FNAME knnXEw3D #define WHICH #define EXCLUDE #include "knn3DdistX.h" #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE /* GENERAL INTERFACE */ /* general interface for k-nearest neighbours of two point patterns */ void knnX3Dinterface( /* inputs */ int *n1, double *x1, double *y1, double *z1, int *id1, int *n2, double *x2, double *y2, double *z2, int *id2, int *kmax, /* options */ int *exclude, int *wantdist, int *wantwhich, /* output matrices (n1 * kmax) in ROW MAJOR order */ double *nnd, int *nnwhich, /* upper bound on pairwise distance */ double *huge /* some inputs + outputs are not used in all functions */ ) { int ex, di, wh; ex = (*exclude != 0); di = (*wantdist != 0); wh = (*wantwhich != 0); if(!ex) { if(di && wh) { knnXdw3D(n1,x1,y1,z1,id1,n2,x2,y2,z2,id2,kmax,nnd,nnwhich,huge); } else if(di) { knnXd3D(n1,x1,y1,z1,id1,n2,x2,y2,z2,id2,kmax,nnd,nnwhich,huge); } else if(wh) { knnXw3D(n1,x1,y1,z1,id1,n2,x2,y2,z2,id2,kmax,nnd,nnwhich,huge); } } else { if(di && wh) { knnXEdw3D(n1,x1,y1,z1,id1,n2,x2,y2,z2,id2,kmax,nnd,nnwhich,huge); } else if(di) { knnXEd3D(n1,x1,y1,z1,id1,n2,x2,y2,z2,id2,kmax,nnd,nnwhich,huge); } else if(wh) { knnXEw3D(n1,x1,y1,z1,id1,n2,x2,y2,z2,id2,kmax,nnd,nnwhich,huge); } } } spatstat.geom/src/seg2pix.h0000644000176200001440000001022114611065353015364 0ustar liggesusers/* seg2pix.h Code template for seg2pix.c $Revision: 1.4 $ $Date: 2022/10/22 02:32:10 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Macros: FNAME name of function SUMUP #defined if crossings should be counted (weights summed) V matrix index macro (in seg2pix.c) DEBUG debug if #defined */ #undef INCREMENT #undef ZERO #ifdef SUMUP #define ZERO (double) 0.0 #define INCREMENT(I,J) V(I,J) += wi #else #define ZERO 0 #define INCREMENT(I,J) V(I,J) = 1 #endif void FNAME( int *ns, /* number of segments */ double *x0, double *y0, double *x1, double *y1, /* coordinates of segment endpoints */ #ifdef SUMUP double *w, /* weights attached to segments */ #endif int *nx, int *ny, /* dimensions of pixel array (columns, rows) */ #ifdef SUMUP double *out /* output totals */ #else int *out /* output indicators */ #endif ) { int Ns, Nx, Ny, i, j, k, m, m0, m1, mmin, mmax, maxchunk; double x0i, x1i, y0i, y1i, dx, dy; double leni; double xleft, yleft, xright, yright, slope; double xstart, ystart, xfinish, yfinish; int mleft, mright, kstart, kfinish, kmin, kmax; #ifdef SUMUP double wi; #endif Ns = *ns; Nx = *nx; Ny = *ny; for(k = 0; k < Ny - 1; k++) for(j = 0; j < Nx - 1; j++) V(k, j) = ZERO; OUTERCHUNKLOOP(i, Ns, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, Ns, maxchunk, 8196) { x0i = x0[i]; y0i = y0[i]; x1i = x1[i]; y1i = y1[i]; #ifdef SUMUP wi = w[i]; #endif dx = x1i - x0i; dy = y1i - y0i; leni = hypot(dx, dy); #ifdef DEBUG Rprintf("(%lf, %lf) to (%lf, %lf)\n", x0i, y0i, x1i, y1i); #endif if(leni < 0.001) { /* tiny segment */ #ifdef DEBUG Rprintf("tiny\n"); #endif k = clamp((int) floor(x0i), 0, Nx-1); j = clamp((int) floor(y0i), 0, Ny-1); INCREMENT(j, k); } else if(floor(x1i) == floor(x0i) && floor(y1i) == floor(y0i)) { /* contained in one cell */ #ifdef DEBUG Rprintf("contained in one cell\n"); #endif k = clamp((int) floor(x0i), 0, Nx-1); j = clamp((int) floor(y0i), 0, Ny-1); INCREMENT(j, k); } else if(floor(y1i) == floor(y0i)) { /* horizontal */ #ifdef DEBUG Rprintf("horizontal\n"); #endif j = clamp((int) floor(y1i), 0, Ny-1); m0 = clamp((int) floor(x0i), 0, Nx-1); m1 = clamp((int) floor(x1i), 0, Nx-1); mmin = (m0 < m1) ? m0: m1; mmax = (m0 < m1) ? m1: m0; #ifdef DEBUG Rprintf("row %d: columns [%d, %d]\n", j, mmin, mmax); #endif for(k = mmin; k <= mmax; k++) INCREMENT(j,k); } else if(floor(x1i) == floor(x0i)) { /* vertical */ #ifdef DEBUG Rprintf("vertical\n"); #endif k = clamp((int) floor(x1i), 0, Nx-1); m0 = clamp((int) floor(y0i), 0, Ny-1); m1 = clamp((int) floor(y1i), 0, Ny-1); mmin = (m0 < m1) ? m0: m1; mmax = (m0 < m1) ? m1: m0; #ifdef DEBUG Rprintf("column %d: rows [%d, %d]\n", k, mmin, mmax); #endif for(j = mmin; j <= mmax; j++) INCREMENT(j,k); } else { /* general case */ #ifdef DEBUG Rprintf("general\n"); #endif if(x1i > x0i) { xleft = x0i; yleft = y0i; xright = x1i; yright = y1i; } else { xleft = x1i; yleft = y1i; xright = x0i; yright = y0i; } slope = (yright - yleft)/(xright - xleft); mleft = clamp((int) floor(xleft), 0, Nx-1); mright = clamp((int) floor(xright), 0, Nx-1); #ifdef DEBUG Rprintf("column range [%d, %d]\n", mleft, mright); #endif /* treat each vertical slice */ for(m = mleft; m <= mright; m++) { if(m == mleft) { xstart = xleft; ystart = yleft; } else { xstart = m; ystart = yleft + slope * (xstart - xleft); } if(m == mright) { xfinish = xright; yfinish = yright; } else { xfinish = m+1; yfinish = yleft + slope * (xfinish - xleft); } kstart = clamp((int) floor(ystart), 0, Ny-1); kfinish = clamp((int) floor(yfinish), 0, Ny-1); kmin = (kstart < kfinish) ? kstart : kfinish; kmax = (kstart < kfinish) ? kfinish : kstart; #ifdef DEBUG Rprintf("column %d: rows [%d, %d]\n", m, kmin, kmax); #endif for(k = kmin; k <= kmax; k++) INCREMENT(k, m); } } /* end of if-else */ } } #ifdef DEBUG Rprintf("done\n"); #endif } spatstat.geom/src/nn3Ddist.h0000644000176200001440000000402314611065353015474 0ustar liggesusers/* nn3Ddist.h Code template for nearest-neighbour algorithms for 3D point patterns Input is a single point pattern - supports 'nndist' and 'nnwhich' This code is #included multiple times in nn3Ddist.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour Either or both DIST and WHICH may be defined. THE FOLLOWING CODE ASSUMES THAT THE POINT PATTERN IS SORTED IN ASCENDING ORDER OF THE z COORDINATE $Revision: 1.7 $ $Date: 2022/10/21 10:43:01 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ void FNAME( /* inputs */ int *n, double *x, double *y, double *z, /* outputs */ double *nnd, int *nnwhich, /* upper bound on distance */ double *huge ) { int npoints, i, j, maxchunk; double d2, d2min, xi, yi, zi, dx, dy, dz, dz2, hu, hu2; #ifdef WHICH int which; #endif hu = *huge; hu2 = hu * hu; npoints = *n; OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { d2min = hu2; #ifdef WHICH which = -1; #endif xi = x[i]; yi = y[i]; zi = z[i]; /* search backward */ if(i > 0){ for(j = i - 1; j >= 0; --j) { dz = z[j] - zi; dz2 = dz * dz; if(dz2 > d2min) break; dx = x[j] - xi; dy = y[j] - yi; d2 = dx * dx + dy * dy + dz2; if (d2 < d2min) { d2min = d2; #ifdef WHICH which = j; #endif } } } /* search forward */ if(i < npoints - 1) { for(j = i + 1; j < npoints; ++j) { dz = z[j] - zi; dz2 = dz * dz; if(dz2 > d2min) break; dx = x[j] - xi; dy = y[j] - yi; d2 = dx * dx + dy * dy + dz2; if (d2 < d2min) { d2min = d2; #ifdef WHICH which = j; #endif } } } #ifdef DIST nnd[i] = sqrt(d2min); #endif #ifdef WHICH /* convert to R indexing */ nnwhich[i] = which + 1; #endif } } } spatstat.geom/src/fardist.h0000644000176200001440000000255114611065353015446 0ustar liggesusers/* fardist.h Code template for fardist.c Macros used: FNAME function name SQUARED #defined if squared distances should be returned. Copyright (C) Adrian Baddeley, Rolf Turner and Ege Rubak 2014 Licence: GPL >= 2 $Revision: 1.4 $ $Date: 2022/10/21 10:43:01 $ */ void FNAME( /* inputs */ int *nx, double *x0, double *xstep, /* pixel grid dimensions */ int *ny, double *y0, double *ystep, /* pixel grid dimensions */ int *np, double *xp, double *yp, /* data points */ /* outputs */ double *dfar /* output grid */ ) { int Nxcol, Nyrow, Npoints; int i, j, k, ijpos; double X0, Y0, Xstep, Ystep, yi, xj; double d2, d2max, dx, dy; Nxcol = *nx; Nyrow = *ny; Npoints = *np; X0 = *x0; Y0 = *y0; Xstep = *xstep; Ystep = *ystep; if(Npoints == 0) return; /* loop over pixels */ for(j = 0, xj = X0; j < Nxcol; j++, xj += Xstep) { R_CheckUserInterrupt(); for(i = 0, yi = Y0; i < Nyrow; i++, yi += Ystep) { d2max = 0.0; for(k = 0; k < Npoints; k++) { dx = xj - xp[k]; dy = yi - yp[k]; d2 = dx * dx + dy * dy; if(d2 > d2max) d2max = d2; } ijpos = i + j * Nyrow; #ifdef SQUARED dfar[ijpos] = d2max; #else dfar[ijpos] = sqrt(d2max); #endif /* end of loop over grid points (i, j) */ } } } spatstat.geom/src/veegraf.c0000644000176200001440000000714214611065353015425 0ustar liggesusers/* veegraf.c $Revision: 1.3 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Given the edges of a graph, determine all "Vees" i.e. triples (i, j, k) where i ~ j and i ~ k. */ #include #include #include #include "chunkloop.h" #undef DEBUGVEE SEXP graphVees(SEXP nv, /* number of vertices */ SEXP iedge, /* vectors of indices of ends of each edge */ SEXP jedge) /* all arguments are integer */ /* Edges should NOT be repeated symmetrically. Indices need not be sorted. */ { int Nv, Ne; int *ie, *je; /* edges */ int *it, *jt, *kt; /* vectors of indices of triples */ int Nt, Ntmax; /* number of triples */ int Nj; int *jj; /* scratch storage */ int i, j, k, m, mj, mk, Nmore, maxchunk; /* output */ SEXP iTout, jTout, kTout, out; int *ito, *jto, *kto; /* =================== Protect R objects from garbage collector ======= */ PROTECT(nv = AS_INTEGER(nv)); PROTECT(iedge = AS_INTEGER(iedge)); PROTECT(jedge = AS_INTEGER(jedge)); /* That's 3 protected objects */ /* numbers of vertices and edges */ Nv = *(INTEGER_POINTER(nv)); Ne = LENGTH(iedge); /* input arrays */ ie = INTEGER_POINTER(iedge); je = INTEGER_POINTER(jedge); /* initialise storage (with a guess at max size) */ Ntmax = 3 * Ne; it = (int *) R_alloc(Ntmax, sizeof(int)); jt = (int *) R_alloc(Ntmax, sizeof(int)); kt = (int *) R_alloc(Ntmax, sizeof(int)); Nt = 0; /* initialise scratch storage */ jj = (int *) R_alloc(Ne, sizeof(int)); XOUTERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { R_CheckUserInterrupt(); XINNERCHUNKLOOP(i, 1, Nv, maxchunk, 8196) { #ifdef DEBUGVEE Rprintf("i=%d ---------- \n", i); #endif /* Find Vee triples with apex 'i' */ /* First, find all vertices j connected to i */ Nj = 0; for(m = 0; m < Ne; m++) { if(ie[m] == i) { jj[Nj] = je[m]; Nj++; } else if(je[m] == i) { jj[Nj] = ie[m]; Nj++; } } /* save triples (i,j,k) */ #ifdef DEBUGVEE Rprintf("Nj = %d\n", Nj); #endif if(Nj > 1) { #ifdef DEBUGVEE Rprintf("i=%d\njj=\n", i); for(mj = 0; mj < Nj; mj++) Rprintf("%d ", jj[mj]); Rprintf("\n\n"); #endif for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; /* add (i, j, k) to list of triangles */ if(Nt >= Ntmax) { /* overflow - allocate more space */ Nmore = 2 * Ntmax; #ifdef DEBUGVEE Rprintf("Doubling space from %d to %d\n", Ntmax, Nmore); #endif it = (int *) S_realloc((char *) it, Nmore, Ntmax, sizeof(int)); jt = (int *) S_realloc((char *) jt, Nmore, Ntmax, sizeof(int)); kt = (int *) S_realloc((char *) kt, Nmore, Ntmax, sizeof(int)); Ntmax = Nmore; } it[Nt] = i; jt[Nt] = j; kt[Nt] = k; Nt++; } } } } } /* allocate space for output */ PROTECT(iTout = NEW_INTEGER(Nt)); PROTECT(jTout = NEW_INTEGER(Nt)); PROTECT(kTout = NEW_INTEGER(Nt)); PROTECT(out = NEW_LIST(3)); /* that's 3+4=7 protected objects */ ito = INTEGER_POINTER(iTout); jto = INTEGER_POINTER(jTout); kto = INTEGER_POINTER(kTout); /* copy triplet indices to output vectors */ for(m = 0; m < Nt; m++) { ito[m] = it[m]; jto[m] = jt[m]; kto[m] = kt[m]; } /* insert output vectors in output list */ SET_VECTOR_ELT(out, 0, iTout); SET_VECTOR_ELT(out, 1, jTout); SET_VECTOR_ELT(out, 2, kTout); UNPROTECT(7); return(out); } spatstat.geom/src/distances.c0000644000176200001440000002307314611065353015764 0ustar liggesusers/* distances.c Distances between pairs of points $Revision: 1.34 $ $Date: 2022/10/22 10:09:51 $ Cpairdist Pairwise distances Cpair2dist Pairwise distances squared CpairPdist Pairwise distances with periodic correction CpairP2dist Pairwise distances squared, with periodic correction Ccrossdist Pairwise distances for two sets of points Ccross2dist Pairwise distances squared, for two sets of points CcrossPdist Pairwise distances for two sets of points, periodic correction Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include #include #include "chunkloop.h" double sqrt(double x); void Cpairdist( /* inputs */ int *n, double *x, double *y, int *squared, /* output */ double *d ) { void Cpair1dist(int *n, double *x, double *y, double *d); void Cpair2dist(int *n, double *x, double *y, double *d); if(*squared == 0) { Cpair1dist(n, x, y, d); } else { Cpair2dist(n, x, y, d); } } void Cpair1dist( /* inputs */ int *n, double *x, double *y, /* output */ double *d ) { int i, j, npoints, maxchunk; double *dp; double xi, yi, dx, dy, dist; npoints = *n; /* set d[0,0] = 0 */ *d = 0.0; OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { xi = x[i]; yi = y[i]; /* point at the start of column i */ dp = d + i * npoints; /* set diagonal to zero */ dp[i] = 0.0; for (j=0; j < i; j++) { dx = x[j] - xi; dy = y[j] - yi; dist = sqrt( dx * dx + dy * dy ); /* upper triangle */ *dp = dist; ++dp; /* lower triangle */ d[ j * npoints + i] = dist; } } } } /* squared distances */ void Cpair2dist( /* inputs */ int *n, double *x, double *y, /* output */ double *d ) { int i, j, npoints, maxchunk; double *dp; double xi, yi, dx, dy, dist; npoints = *n; /* set d[0,0] = 0 */ *d = 0.0; OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { xi = x[i]; yi = y[i]; /* point at the start of column i */ dp = d + i * npoints; /* set diagonal to zero */ dp[i] = 0.0; for (j=0; j < i; j++) { dx = x[j] - xi; dy = y[j] - yi; dist = dx * dx + dy * dy; /* upper triangle */ *dp = dist; ++dp; /* lower triangle */ d[ j * npoints + i] = dist; } } } } void Ccrossdist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, int *squared, /* output */ double *d ) { void Ccross1dist(int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, double *d); void Ccross2dist(int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, double *d); if(*squared == 0) { Ccross1dist(nfrom, xfrom, yfrom, nto, xto, yto, d); } else { Ccross2dist(nfrom, xfrom, yfrom, nto, xto, yto, d); } } void Ccross1dist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, /* output */ double *d ) { int i, j, nf, nt, maxchunk; double *dptr; double xj, yj, dx, dy; nf = *nfrom; nt = *nto; dptr = d; OUTERCHUNKLOOP(j, nt, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, nt, maxchunk, 16384) { xj = xto[j]; yj = yto[j]; for(i = 0; i < nf; i++, dptr++) { dx = xj - xfrom[i]; dy = yj - yfrom[i]; *dptr = sqrt( dx * dx + dy * dy ); } } } } /* squared distances */ void Ccross2dist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, /* output */ double *d ) { int i, j, nf, nt, maxchunk; double *dptr; double xj, yj, dx, dy; nf = *nfrom; nt = *nto; dptr = d; OUTERCHUNKLOOP(j, nt, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, nt, maxchunk, 16384) { xj = xto[j]; yj = yto[j]; for(i = 0; i < nf; i++, dptr++) { dx = xj - xfrom[i]; dy = yj - yfrom[i]; *dptr = dx * dx + dy * dy; } } } } /* distances with periodic correction */ void CpairPdist( /* inputs */ int *n, double *x, double *y, double *xwidth, double *yheight, int *squared, /* output */ double *d ) { void CpairP1dist(int *n, double *x, double *y, double *xwidth, double *yheight, double *d); void CpairP2dist(int *n, double *x, double *y, double *xwidth, double *yheight, double *d); if(*squared == 0) { CpairP1dist(n, x, y, xwidth, yheight, d); } else { CpairP2dist(n, x, y, xwidth, yheight, d); } } void CpairP1dist( /* inputs */ int *n, double *x, double *y, double *xwidth, double *yheight, /* output */ double *d ) { int i, j, npoints, maxchunk; double *dp; double xi, yi, dx, dy, dx2, dy2, dx2p, dy2p, dist, wide, high; npoints = *n; wide = *xwidth; high = *yheight; /* set d[0,0] = 0 */ *d = 0.0; OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { xi = x[i]; yi = y[i]; /* point at the start of column i */ dp = d + i * npoints; /* set diagonal to zero */ dp[i] = 0.0; for (j=0; j < i; j++) { dx = x[j] - xi; dy = y[j] - yi; dx2p = dx * dx; dy2p = dy * dy; dx2 = (dx - wide) * (dx - wide); dy2 = (dy - high) * (dy - high); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; dx2 = (dx + wide) * (dx + wide); dy2 = (dy + high) * (dy + high); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; dist = sqrt( dx2p + dy2p ); /* upper triangle */ *dp = dist; ++dp; /* lower triangle */ d[ j * npoints + i] = dist; } } } } /* same function without the sqrt */ void CpairP2dist( /* inputs */ int *n, double *x, double *y, double *xwidth, double *yheight, /* output */ double *d ) { int i, j, npoints, maxchunk; double *dp; double xi, yi, dx, dy, dx2, dy2, dx2p, dy2p, dist, wide, high; npoints = *n; wide = *xwidth; high = *yheight; /* set d[0,0] = 0 */ *d = 0.0; OUTERCHUNKLOOP(i, npoints, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, npoints, maxchunk, 16384) { xi = x[i]; yi = y[i]; /* point at the start of column i */ dp = d + i * npoints; /* set diagonal to zero */ dp[i] = 0.0; for (j=0; j < i; j++) { dx = x[j] - xi; dy = y[j] - yi; dx2p = dx * dx; dy2p = dy * dy; dx2 = (dx - wide) * (dx - wide); dy2 = (dy - high) * (dy - high); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; dx2 = (dx + wide) * (dx + wide); dy2 = (dy + high) * (dy + high); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; dist = dx2p + dy2p; /* upper triangle */ *dp = dist; ++dp; /* lower triangle */ d[ j * npoints + i] = dist; } } } } void CcrossPdist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, double *xwidth, double *yheight, int *squared, /* output */ double *d ) { void CcrossP1dist(int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, double *xwidth, double *yheight, double *d); void CcrossP2dist(int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, double *xwidth, double *yheight, double *d); if(*squared == 0) { CcrossP1dist(nfrom, xfrom, yfrom, nto, xto, yto, xwidth, yheight, d); } else { CcrossP2dist(nfrom, xfrom, yfrom, nto, xto, yto, xwidth, yheight, d); } } void CcrossP1dist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, double *xwidth, double *yheight, /* output */ double *d ) { int i, j, nf, nt, maxchunk; double *dptr; double xj, yj, dx, dy, dx2, dy2, dx2p, dy2p, wide, high; nf = *nfrom; nt = *nto; wide = *xwidth; high = *yheight; dptr = d; OUTERCHUNKLOOP(j, nt, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, nt, maxchunk, 16384) { xj = xto[j]; yj = yto[j]; for(i = 0; i < nf; i++, dptr++) { dx = xj - xfrom[i]; dy = yj - yfrom[i]; dx2p = dx * dx; dy2p = dy * dy; dx2 = (dx - wide) * (dx - wide); dy2 = (dy - high) * (dy - high); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; dx2 = (dx + wide) * (dx + wide); dy2 = (dy + high) * (dy + high); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; *dptr = sqrt( dx2p + dy2p ); } } } } void CcrossP2dist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, int *nto, double *xto, double *yto, double *xwidth, double *yheight, /* output */ double *d ) { int i, j, nf, nt, maxchunk; double *dptr; double xj, yj, dx, dy, dx2, dy2, dx2p, dy2p, wide, high; nf = *nfrom; nt = *nto; wide = *xwidth; high = *yheight; dptr = d; OUTERCHUNKLOOP(j, nt, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, nt, maxchunk, 16384) { xj = xto[j]; yj = yto[j]; for(i = 0; i < nf; i++, dptr++) { dx = xj - xfrom[i]; dy = yj - yfrom[i]; dx2p = dx * dx; dy2p = dy * dy; dx2 = (dx - wide) * (dx - wide); dy2 = (dy - high) * (dy - high); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; dx2 = (dx + wide) * (dx + wide); dy2 = (dy + high) * (dy + high); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; *dptr = dx2p + dy2p; } } } } spatstat.geom/src/discs.c0000644000176200001440000000364414611065353015116 0ustar liggesusers#include #include /* discs.c Fill binary mask with discs with given centres and radii $Revision: 1.6 $ $Date: 2022/10/20 10:57:43 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ void discs2grid( /* inputs */ int *nx, double *x0, double *xstep, int *ny, double *y0, double *ystep, /* pixel grid dimensions */ int *nd, double *xd, double *yd, double *rd, /* disc parameters */ /* output */ int *out) { int Nxcol, Nyrow, Ndiscs; double X0, Y0, Xstep, Ystep; int i, j, k; double xk, yk, rk, rk2, dx, dymax; int imin, imax, jmin, jmax, iminj, imaxj, Nxcol1, Nyrow1; Nxcol = *nx; Nyrow = *ny; Ndiscs = *nd; X0 = *x0; Y0 = *y0; Xstep = *xstep; Ystep = *ystep; if(Ndiscs == 0) return; Nxcol1 = Nxcol - 1; Nyrow1 = Nyrow - 1; /* loop over discs */ for(k = 0; k < Ndiscs; k++) { R_CheckUserInterrupt(); xk = xd[k]; yk = yd[k]; rk = rd[k]; /* find valid range of i and j */ imax = floor( (yk + rk - Y0)/Ystep); imin = ceil((yk - rk - Y0)/Ystep); jmax = floor( (xk + rk - X0)/Xstep); jmin = ceil((xk - rk - X0)/Xstep); if(imax >= 0 && imin < Nyrow && jmax >= 0 && jmin < Nxcol && imax >= imin && jmax >= jmin) { if(imin < 0) imin = 0; if(imax > Nyrow1) imax = Nyrow1; if(jmin < 0) jmin = 0; if(jmax > Nxcol1) jmax = Nxcol1; rk2 = rk * rk; /* loop over relevant pixels */ for(j = jmin, dx=X0 + jmin * Xstep - xk; j <= jmax; j++, dx += Xstep) { dymax = sqrt(rk2 - dx * dx); imaxj = floor( (yk + dymax - Y0)/Ystep); iminj = ceil((yk - dymax - Y0)/Ystep); if(imaxj >= 0 && iminj < Nyrow) { if(iminj < 0) iminj = 0; if(imaxj > Nyrow1) imaxj = Nyrow1; for(i = iminj; i <= imaxj; i++) out[i + j * Nyrow] = 1; } } } } } spatstat.geom/src/knngrid.c0000644000176200001440000000374514611065353015447 0ustar liggesusers/* knngrid.c K-th Nearest Neighbour Distances from a pixel grid to a point pattern Copyright (C) Adrian Baddeley, Jens Oehlschlaegel and Rolf Turner 2000-2022 Licence: GNU Public Licence >= 2 $Revision: 1.9 $ $Date: 2022/10/22 09:29:51 $ Function body definition is #included from knngrid.h THE FOLLOWING FUNCTIONS ASSUME THAT x IS SORTED IN ASCENDING ORDER */ #undef SPATSTAT_DEBUG #include #include #include #include "yesno.h" double sqrt(double x); /* THE FOLLOWING CODE ASSUMES THAT x IS SORTED IN ASCENDING ORDER */ #undef FNAME #undef DIST #undef WHICH /* knnGdw nearest neighbours 1:kmax returns distances and indices */ #define FNAME knnGdw #define DIST #define WHICH #include "knngrid.h" #undef FNAME #undef DIST #undef WHICH /* knnGd nearest neighbours 1:kmax returns distances only */ #define FNAME knnGd #define DIST #include "knngrid.h" #undef FNAME #undef DIST #undef WHICH /* knnGw nearest neighbours 1:kmax returns indices only */ #define FNAME knnGw #define WHICH #include "knngrid.h" #undef FNAME #undef DIST #undef WHICH /* >>>>>>>>>>> GENERAL INTERFACE <<<<<<<<<<<<<<<< */ /* general interface */ void knnGinterface( /* inputs */ int *nx, double *x0, double *xstep, int *ny, double *y0, double *ystep, /* pixel grid dimensions */ int *np, double *xp, double *yp, /* data points */ int *kmax, /* options */ int *wantdist, int *wantwhich, /* outputs */ double *nnd, int *nnwhich, /* upper bound on pairwise distance */ double *huge /* some inputs + outputs are not used in all functions */ ) { int di, wh; di = (*wantdist != 0); wh = (*wantwhich != 0); if(di && wh) { knnGdw(nx, x0, xstep, ny, y0, ystep, np, xp, yp, kmax, nnd, nnwhich, huge); } else if(di) { knnGd(nx, x0, xstep, ny, y0, ystep, np, xp, yp, kmax, nnd, nnwhich, huge); } else if(wh) { knnGw(nx, x0, xstep, ny, y0, ystep, np, xp, yp, kmax, nnd, nnwhich, huge); } } spatstat.geom/src/crossloop.h0000644000176200001440000000356214611065353016040 0ustar liggesusers/* crossloop.h Generic code template for loop for cross-close-pairs operations collecting contributions to point x_i from all points y_j such that ||x_i - y_j|| <= r cpp variables used: INITIAL_I code executed at start of 'i' loop CONTRIBUTE_IJ code executed to compute contribution from j to i COMMIT_I code executed to save total contribution to i C variables used: int i, j, n1, n2, maxchunk, jleft; double x1i, y1i, xleft, dx, dy, d2, rmax, r2max; double *x1, *y1, *x2, *y2; $Revision: 1.3 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #ifndef CHUNKLOOP_H #include "chunkloop.h" #endif #define CROSSLOOP(INITIAL_I, CONTRIBUTE_IJ, COMMIT_I) \ OUTERCHUNKLOOP(i, n1, maxchunk, 65536) { \ R_CheckUserInterrupt(); \ INNERCHUNKLOOP(i, n1, maxchunk, 65536) { \ \ x1i = x1[i]; \ y1i = y1[i]; \ \ INITIAL_I; \ \ jleft = 0; \ \ /* \ adjust starting point jleft \ */ \ xleft = x1i - rmax; \ while((x2[jleft] < xleft) && (jleft+1 < n2)) \ ++jleft; \ \ /* \ process from j = jleft until dx > rmax \ */ \ for(j=jleft; j < n2; j++) { \ dx = x2[j] - x1i; \ if(dx > rmax) \ break; \ dy = y2[j] - y1i; \ d2 = dx * dx + dy * dy; \ if(d2 <= r2max) { \ /* add this (i, j) pair to output */ \ CONTRIBUTE_IJ; \ } \ } \ COMMIT_I; \ } \ } spatstat.geom/src/maxnnd.h0000644000176200001440000000370614611065353015302 0ustar liggesusers/* maxnnd.h Code template for maxnnd to be #included in minnnd.c Macros: FNAME Function name IGNOREZERO #defined if zero distances should be ignored Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 $Revision: 1.5 $ $Date: 2022/10/22 02:44:15 $ */ /* THE FOLLOWING CODE ASSUMES THAT y IS SORTED IN ASCENDING ORDER */ void FNAME( /* inputs */ int *n, double *x, double *y, double *huge, /* outputs */ double *result ) { int npoints, i, maxchunk, left, right; double d2, d2mini, d2max, xi, yi, dx, dy, dy2, hu, hu2; hu = *huge; hu2 = hu * hu; npoints = *n; /* maximum (over all i) nearest-neighbour distance, squared */ d2max = 0.0; if(npoints == 0) return; /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < npoints) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > npoints) maxchunk = npoints; for(; i < maxchunk; i++) { xi = x[i]; yi = y[i]; /* nearest-neighbour distance for point i, squared */ d2mini = hu2; if(i < npoints - 1) { /* search forward */ for(right = i + 1; right < npoints; ++right) { dy = y[right] - yi; dy2 = dy * dy; if(dy2 > d2mini) break; dx = x[right] - xi; d2 = dx * dx + dy2; if (d2 < d2mini) { #ifdef IGNOREZERO if(d2 > 0) { #endif d2mini = d2; if(d2mini <= d2max) break; #ifdef IGNOREZERO } #endif } } } if(i > 0 && d2mini > d2max){ /* search backward */ for(left = i - 1; left >= 0; --left) { dy = yi - y[left]; dy2 = dy * dy; if(dy2 > d2mini) break; dx = x[left] - xi; d2 = dx * dx + dy2; if (d2 < d2mini) { #ifdef IGNOREZERO if(d2 > 0) { #endif d2mini = d2; if(d2mini <= d2max) break; #ifdef IGNOREZERO } #endif } } } if(d2mini > d2max) d2max = d2mini; } } *result = d2max; } spatstat.geom/src/knndist.h0000644000176200001440000000737314611065353015473 0ustar liggesusers/* knndist.h Code template for C functions supporting knndist and knnwhich THE FOLLOWING CODE ASSUMES THAT y IS SORTED IN ASCENDING ORDER This code is #included multiple times in knndistance.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour Either or both DIST and WHICH may be defined. Copyright (C) Adrian Baddeley, Jens Oehlschlagel and Rolf Turner 2000-2022 Licence: GPL >= 2 $Revision: 1.4 $ $Date: 2022/10/21 10:43:01 $ */ void FNAME( /* inputs */ int *n, int *kmax, double *x, double *y, /* output matrices (n * kmax) in ROW MAJOR order */ #ifdef DIST double *nnd, #endif #ifdef WHICH int *nnwhich, #endif /* input - upper bound on pairwise distance */ double *huge ) { int npoints, maxchunk, nk, nk1, i, k, k1, left, right, unsorted; double d2, d2minK, xi, yi, dx, dy, dy2, hu, hu2, tmp; double *d2min; #ifdef WHICH int *which; int itmp; #endif hu = *huge; hu2 = hu * hu; npoints = *n; nk = *kmax; nk1 = nk - 1; /* create space to store the nearest neighbour distances and indices for the current point */ d2min = (double *) R_alloc((size_t) nk, sizeof(double)); #ifdef WHICH which = (int *) R_alloc((size_t) nk, sizeof(int)); #endif /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < npoints) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > npoints) maxchunk = npoints; for(; i < maxchunk; i++) { #ifdef SPATSTAT_DEBUG Rprintf("\ni=%d\n", i); #endif /* initialise nn distances and indices */ d2minK = hu2; for(k = 0; k < nk; k++) { d2min[k] = hu2; #ifdef WHICH which[k] = -1; #endif } xi = x[i]; yi = y[i]; /* search backward */ for(left = i - 1; left >= 0; --left) { #ifdef SPATSTAT_DEBUG Rprintf("L"); #endif dy = yi - y[left]; dy2 = dy * dy; if(dy2 > d2minK) break; dx = x[left] - xi; d2 = dx * dx + dy2; if (d2 < d2minK) { /* overwrite last entry */ d2min[nk1] = d2; #ifdef WHICH which[nk1] = left; #endif /* bubble sort */ unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } /* adjust maximum distance */ d2minK = d2min[nk1]; } } /* search forward */ for(right = i + 1; right < npoints; ++right) { #ifdef SPATSTAT_DEBUG Rprintf("R"); #endif dy = y[right] - yi; dy2 = dy * dy; if(dy2 > d2minK) break; dx = x[right] - xi; d2 = dx * dx + dy2; if (d2 < d2minK) { /* overwrite last entry */ d2min[nk1] = d2; #ifdef WHICH which[nk1] = right; #endif /* bubble sort */ unsorted = YES; for(k = nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } /* adjust maximum distance */ d2minK = d2min[nk1]; } } /* search finished for point i */ #ifdef SPATSTAT_DEBUG Rprintf("\n"); #endif /* copy nn distances for point i to output matrix in ROW MAJOR order */ for(k = 0; k < nk; k++) { #ifdef DIST nnd[nk * i + k] = sqrt(d2min[k]); #endif #ifdef WHICH nnwhich[nk * i + k] = which[k] + 1; /* R indexing */ #endif } /* end of i loop */ } } } spatstat.geom/src/knndistance.c0000644000176200001440000001032214611065353016301 0ustar liggesusers/* knndistance.c K-th Nearest Neighbour Distances between points Copyright (C) Adrian Baddeley, Jens Oehlschlaegel and Rolf Turner 2000-2013 Licence: GNU Public Licence >= 2 $Revision: 1.11 $ $Date: 2022/10/22 09:29:51 $ Function definitions are #included from knndist.h and knnXdist.h THE FOLLOWING FUNCTIONS ASSUME THAT y IS SORTED IN ASCENDING ORDER SINGLE LIST: knndsort k-th nearest neighbour distances knnwhich k-th nearest neighbours knnsort k-th nearest neighbours and their distances ONE LIST TO ANOTHER LIST: knnXdist Nearest neighbour distance from one list to another knnXwhich Nearest neighbour ID from one list to another knnX Nearest neighbour ID & distance from one list to another ONE LIST TO ANOTHER OVERLAPPING LIST: knnXEdist Nearest neighbour distance from one list to another, overlapping knnXEwhich Nearest neighbour ID from one list to another, overlapping knnXE Nearest neighbour ID & distance */ #undef SPATSTAT_DEBUG #include #include #include #include "yesno.h" double sqrt(double x); /* THE FOLLOWING CODE ASSUMES THAT y IS SORTED IN ASCENDING ORDER */ /* ------------------- one point pattern X --------------------- */ /* knndsort nearest neighbours 1:kmax returns distances only */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knndsort #define DIST #include "knndist.h" /* knnwhich nearest neighbours 1:kmax returns identifiers only */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knnwhich #define WHICH #include "knndist.h" /* knnsort nearest neighbours 1:kmax returns distances and indices */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knnsort #define DIST #define WHICH #include "knndist.h" /* --------------- two distinct point patterns X and Y --------------- */ /* Turn off the debugging tracer in knnXdist.h */ #undef TRACER /* knnXdist returns distances only */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knnXdist #define DIST #include "knnXdist.h" /* knnXwhich returns identifiers only */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knnXwhich #define WHICH #include "knnXdist.h" /* knnX returns distances and indices */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knnX #define DIST #define WHICH #include "knnXdist.h" /* --------------- overlapping point patterns X and Y --------------- */ /* knnXEdist returns distances only */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knnXEdist #define DIST #define EXCLUDE #include "knnXdist.h" /* knnXEwhich returns identifiers only */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knnXEwhich #define WHICH #define EXCLUDE #include "knnXdist.h" /* knnXE returns distances and indices */ #undef FNAME #undef DIST #undef WHICH #undef EXCLUDE #define FNAME knnXE #define DIST #define WHICH #define EXCLUDE #include "knnXdist.h" /* >>>>>>>>> GENERAL INTERFACE <<<<<<<<<<<<<<<< */ /* general interface for two patterns */ void knnXinterface( /* inputs */ int *n1, double *x1, double *y1, int *id1, int *n2, double *x2, double *y2, int *id2, int *kmax, /* options */ int *exclude, int *wantdist, int *wantwhich, /* outputs */ double *nnd, int *nnwhich, /* input (upper bound) */ double *huge /* some inputs + outputs are not used in all functions */ ) { int ex, di, wh; ex = (*exclude != 0); di = (*wantdist != 0); wh = (*wantwhich != 0); if(!ex) { if(di && wh) { knnX(n1, x1, y1, id1, n2, x2, y2, id2, kmax, nnd, nnwhich, huge); } else if(di) { knnXdist(n1, x1, y1, id1, n2, x2, y2, id2, kmax, nnd, nnwhich, huge); } else if(wh) { knnXwhich(n1, x1, y1, id1, n2, x2, y2, id2, kmax, nnd, nnwhich, huge); } } else { if(di && wh) { knnXE(n1, x1, y1, id1, n2, x2, y2, id2, kmax, nnd, nnwhich, huge); } else if(di) { knnXEdist(n1, x1, y1, id1, n2, x2, y2, id2, kmax, nnd, nnwhich, huge); } else if(wh) { knnXEwhich(n1, x1, y1, id1, n2, x2, y2, id2, kmax, nnd, nnwhich, huge); } } } spatstat.geom/src/dinfty.c0000644000176200001440000000677614611065353015317 0ustar liggesusers/* dinfty.c $Revision: 1.6 $ $Date: 2011/09/20 07:42:18 $ Code by Dominic Schuhmacher Modified by Adrian Baddeley */ #include #include #define COST(I,J) (d)[n * (J) + (I)] int arraymax(int *a, int n); void swap(int i, int j, int *a); int largestmobpos(int *mobile, int *current, int *collectvals, int n); /* ------------ The main function ----------------------------- */ void dinfty_R(int *d, int *num, int *assignment) { int i,j; /* indices */ int lmp, lmq; /* largest mobile position and its neighbor */ int newmax; int n, currmin; int *current, *travel, *mobile, *assig, *distrelev, *collectvals; n = *num; /* scratch space */ assig = (int *) R_alloc((long) n, sizeof(int)); travel = (int *) R_alloc((long) n, sizeof(int)); mobile = (int *) R_alloc((long) n, sizeof(int)); current = (int *) R_alloc((long) n, sizeof(int)); distrelev = (int *) R_alloc((long) n, sizeof(int)); collectvals = (int *) R_alloc((long) (n * n), sizeof(int)); /* */ /* We use the Johnson-Trotter Algorithm for listing permutations */ /* */ /* Initialize the algorithm */ for (i = 0; i < n; i++) { travel[i] = -1; /* all numbers traveling to the left */ mobile[i] = 1; /* all numbers mobile */ current[i] = i; /* current permutation is the identity */ assig[i] = i; /* best permutation up to now is the identity */ distrelev[i] = COST(i, i); /* pick relevant entries in the cost matrix */ } currmin = arraymax(distrelev, n); /* minimal max up to now */ /* The main loop */ while(arraymax(mobile, n) == 1) { lmp = largestmobpos(mobile, current, collectvals, n); lmq = lmp + travel[lmp]; swap(lmp, lmq, current); swap(lmp, lmq, travel); for (i = 0; i < n; i++) { if (current[i] > current[lmq]) travel[i] = -travel[i]; j = i + travel[i]; if (j < 0 || j > n-1 || current[i] < current[j]) mobile[i] = 0; else mobile[i] = 1; distrelev[i] = COST(i, current[i]); } /* Calculation of new maximal value */ newmax = arraymax(distrelev, n); if (newmax < currmin) { currmin = newmax; for (i = 0; i < n; i++) { assig[i] = current[i]; } } } /* For testing: print distance from within C program Rprintf("Prohorov distance is %d\n", currmin); */ /* "Return" the final assignment */ for (i = 0; i < n; i++) { assignment[i] = assig[i] + 1; } } /* ------------------------------------------------------------*/ /* Maximal element of an integer array */ int arraymax(int *a, int n) { int i, amax; if(n < 1) return(-1); amax = a[0]; if(n > 1) for(i = 0; i < n; i++) if(a[i] > amax) amax = a[i]; return(amax); } /* Swap elements i and j in array a */ void swap(int i, int j, int *a) { int v; v = a[i]; a[i] = a[j]; a[j] = v; } /* Return index of largest mobile number in current */ int largestmobpos(int *mobile, int *current, int *collectvals, int n) { int i,j, maxval; j = 0; for (i = 0; i < n; i++) { if (mobile[i] == 1) { collectvals[j] = current[i]; j++; } } maxval = arraymax(collectvals, j); for (i = 0; i < n; i++) { if (current[i] == maxval) { return(i); } } error("Internal error: largestmobpos failed"); return(0); } spatstat.geom/src/closefuns.h0000644000176200001440000006314014611065353016014 0ustar liggesusers/* closefuns.h Function definitions to be #included in closepair.c several times with different values of macros. Macros used: CLOSEFUN name of function for 'closepairs' CROSSFUN name of function for 'crosspairs' DIST if defined, also return d COORDS if defined, also return xi, yi, xj, yj, dx, dy THRESH if defined, also return 1(d < s) ZCOORD if defined, coordinates are 3-dimensional SINGLE if defined, capture only i < j $Revision: 1.11 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #ifdef ZCOORD #define SPACEDIM 3 #else #define SPACEDIM 2 #endif SEXP CLOSEFUN(SEXP xx, SEXP yy, #ifdef ZCOORD SEXP zz, #endif SEXP rr, #ifdef THRESH SEXP ss, #endif SEXP nguess) { double *x, *y; double xi, yi, rmax, r2max, rmaxplus, dx, dy, d2; #ifdef ZCOORD double *z; double zi, dz; #endif int n, k, kmax, kmaxold, maxchunk, i, j, m; /* local storage */ int *iout, *jout; /* R objects in return value */ SEXP Out, iOut, jOut; /* external storage pointers */ int *iOutP, *jOutP; #ifdef COORDS double *xiout, *yiout, *xjout, *yjout, *dxout, *dyout; SEXP xiOut, yiOut, xjOut, yjOut, dxOut, dyOut; double *xiOutP, *yiOutP, *xjOutP, *yjOutP, *dxOutP, *dyOutP; #ifdef ZCOORD double *ziout, *zjout, *dzout; SEXP ziOut, zjOut, dzOut; double *ziOutP, *zjOutP, *dzOutP; #endif #endif #ifdef DIST double *dout; SEXP dOut; double *dOutP; #endif #ifdef THRESH double s, s2; int *tout; SEXP tOut; int *tOutP; #endif /* protect R objects from garbage collector */ PROTECT(xx = AS_NUMERIC(xx)); PROTECT(yy = AS_NUMERIC(yy)); #ifdef ZCOORD PROTECT(zz = AS_NUMERIC(zz)); #endif PROTECT(rr = AS_NUMERIC(rr)); PROTECT(nguess = AS_INTEGER(nguess)); #ifdef THRESH PROTECT(ss = AS_NUMERIC(ss)); #define NINPUTS (3+SPACEDIM) #else #define NINPUTS (2+SPACEDIM) #endif /* Translate arguments from R to C */ x = NUMERIC_POINTER(xx); y = NUMERIC_POINTER(yy); #ifdef ZCOORD z = NUMERIC_POINTER(zz); #endif n = LENGTH(xx); rmax = *(NUMERIC_POINTER(rr)); kmax = *(INTEGER_POINTER(nguess)); r2max = rmax * rmax; rmaxplus = rmax + rmax/16.0; #ifdef THRESH s = *(NUMERIC_POINTER(ss)); s2 = s * s; #endif k = 0; /* k is the next available storage location and also the current length of the list */ if(n > 0 && kmax > 0) { /* allocate space */ iout = (int *) R_alloc(kmax, sizeof(int)); jout = (int *) R_alloc(kmax, sizeof(int)); #ifdef COORDS xiout = (double *) R_alloc(kmax, sizeof(double)); yiout = (double *) R_alloc(kmax, sizeof(double)); xjout = (double *) R_alloc(kmax, sizeof(double)); yjout = (double *) R_alloc(kmax, sizeof(double)); dxout = (double *) R_alloc(kmax, sizeof(double)); dyout = (double *) R_alloc(kmax, sizeof(double)); #ifdef ZCOORD ziout = (double *) R_alloc(kmax, sizeof(double)); zjout = (double *) R_alloc(kmax, sizeof(double)); dzout = (double *) R_alloc(kmax, sizeof(double)); #endif #endif #ifdef DIST dout = (double *) R_alloc(kmax, sizeof(double)); #endif #ifdef THRESH tout = (int *) R_alloc(kmax, sizeof(int)); #endif /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < n) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > n) maxchunk = n; for(; i < maxchunk; i++) { xi = x[i]; yi = y[i]; #ifdef ZCOORD zi = z[i]; #endif #ifndef SINGLE if(i > 0) { /* scan backward */ for(j = i - 1; j >= 0; j--) { dx = x[j] - xi; if(dx < -rmaxplus) break; dy = y[j] - yi; d2 = dx * dx + dy * dy; #ifdef ZCOORD if(d2 <= r2max) { dz = z[j] - zi; d2 = d2 + dz * dz; #endif if(d2 <= r2max) { /* add this (i, j) pair to output */ if(k >= kmax) { /* overflow; allocate more space */ kmaxold = kmax; kmax = 2 * kmax; iout = intRealloc(iout, kmaxold, kmax); jout = intRealloc(jout, kmaxold, kmax); #ifdef COORDS xiout = dblRealloc(xiout, kmaxold, kmax); yiout = dblRealloc(yiout, kmaxold, kmax); xjout = dblRealloc(xjout, kmaxold, kmax); yjout = dblRealloc(yjout, kmaxold, kmax); dxout = dblRealloc(dxout, kmaxold, kmax); dyout = dblRealloc(dyout, kmaxold, kmax); #ifdef ZCOORD ziout = dblRealloc(ziout, kmaxold, kmax); zjout = dblRealloc(zjout, kmaxold, kmax); dzout = dblRealloc(dzout, kmaxold, kmax); #endif #endif #ifdef DIST dout = dblRealloc(dout, kmaxold, kmax); #endif #ifdef THRESH tout = intRealloc(tout, kmaxold, kmax); #endif } jout[k] = j + 1; /* R indexing */ iout[k] = i + 1; #ifdef COORDS xiout[k] = xi; yiout[k] = yi; xjout[k] = x[j]; yjout[k] = y[j]; dxout[k] = dx; dyout[k] = dy; #ifdef ZCOORD ziout[k] = zi; zjout[k] = z[j]; dzout[k] = dz; #endif #endif #ifdef DIST dout[k] = sqrt(d2); #endif #ifdef THRESH tout[k] = (d2 <= s2) ? 1 : 0; #endif ++k; } #ifdef ZCOORD } #endif } } #endif if(i + 1 < n) { /* scan forward */ for(j = i + 1; j < n; j++) { dx = x[j] - xi; if(dx > rmaxplus) break; dy = y[j] - yi; d2 = dx * dx + dy * dy; #ifdef ZCOORD if(d2 <= r2max) { dz = z[j] - zi; d2 = d2 + dz * dz; #endif if(d2 <= r2max) { /* add this (i, j) pair to output */ if(k >= kmax) { /* overflow; allocate more space */ kmaxold = kmax; kmax = 2 * kmax; iout = intRealloc(iout, kmaxold, kmax); jout = intRealloc(jout, kmaxold, kmax); #ifdef COORDS xiout = dblRealloc(xiout, kmaxold, kmax); yiout = dblRealloc(yiout, kmaxold, kmax); xjout = dblRealloc(xjout, kmaxold, kmax); yjout = dblRealloc(yjout, kmaxold, kmax); dxout = dblRealloc(dxout, kmaxold, kmax); dyout = dblRealloc(dyout, kmaxold, kmax); #ifdef ZCOORD ziout = dblRealloc(ziout, kmaxold, kmax); zjout = dblRealloc(zjout, kmaxold, kmax); dzout = dblRealloc(dzout, kmaxold, kmax); #endif #endif #ifdef DIST dout = dblRealloc(dout, kmaxold, kmax); #endif #ifdef THRESH tout = intRealloc(tout, kmaxold, kmax); #endif } jout[k] = j + 1; /* R indexing */ iout[k] = i + 1; #ifdef COORDS xiout[k] = xi; yiout[k] = yi; xjout[k] = x[j]; yjout[k] = y[j]; dxout[k] = dx; dyout[k] = dy; #ifdef ZCOORD ziout[k] = zi; zjout[k] = z[j]; dzout[k] = dz; #endif #endif #ifdef DIST dout[k] = sqrt(d2); #endif #ifdef THRESH tout[k] = (d2 <= s2) ? 1 : 0; #endif ++k; } #ifdef ZCOORD } #endif } } /* end of i loop */ } } } /* return a list of vectors */ PROTECT(iOut = NEW_INTEGER(k)); PROTECT(jOut = NEW_INTEGER(k)); #ifdef COORDS PROTECT(xiOut = NEW_NUMERIC(k)); PROTECT(yiOut = NEW_NUMERIC(k)); PROTECT(xjOut = NEW_NUMERIC(k)); PROTECT(yjOut = NEW_NUMERIC(k)); PROTECT(dxOut = NEW_NUMERIC(k)); PROTECT(dyOut = NEW_NUMERIC(k)); #ifdef ZCOORD PROTECT(ziOut = NEW_NUMERIC(k)); PROTECT(zjOut = NEW_NUMERIC(k)); PROTECT(dzOut = NEW_NUMERIC(k)); #endif #endif #ifdef DIST PROTECT(dOut = NEW_NUMERIC(k)); #endif #ifdef THRESH PROTECT(tOut = NEW_INTEGER(k)); #endif if(k > 0) { iOutP = INTEGER_POINTER(iOut); jOutP = INTEGER_POINTER(jOut); #ifdef COORDS xiOutP = NUMERIC_POINTER(xiOut); yiOutP = NUMERIC_POINTER(yiOut); xjOutP = NUMERIC_POINTER(xjOut); yjOutP = NUMERIC_POINTER(yjOut); dxOutP = NUMERIC_POINTER(dxOut); dyOutP = NUMERIC_POINTER(dyOut); #ifdef ZCOORD ziOutP = NUMERIC_POINTER(ziOut); zjOutP = NUMERIC_POINTER(zjOut); dzOutP = NUMERIC_POINTER(dzOut); #endif #endif #ifdef DIST dOutP = NUMERIC_POINTER(dOut); #endif #ifdef THRESH tOutP = INTEGER_POINTER(tOut); #endif for(m = 0; m < k; m++) { iOutP[m] = iout[m]; jOutP[m] = jout[m]; #ifdef COORDS xiOutP[m] = xiout[m]; yiOutP[m] = yiout[m]; xjOutP[m] = xjout[m]; yjOutP[m] = yjout[m]; dxOutP[m] = dxout[m]; dyOutP[m] = dyout[m]; #ifdef ZCOORD ziOutP[m] = ziout[m]; zjOutP[m] = zjout[m]; dzOutP[m] = dzout[m]; #endif #endif #ifdef DIST dOutP[m] = dout[m]; #endif #ifdef THRESH tOutP[m] = tout[m]; #endif } } #define HEAD 2 #ifdef THRESH #define NECK 1 #else #define NECK 0 #endif #ifdef COORDS #define MIDDLE (3*SPACEDIM) #else #define MIDDLE 0 #endif #ifdef DIST #define TAIL 1 #else #define TAIL 0 #endif PROTECT(Out = NEW_LIST(HEAD+NECK+MIDDLE+TAIL)); SET_VECTOR_ELT(Out, 0, iOut); SET_VECTOR_ELT(Out, 1, jOut); #ifdef THRESH SET_VECTOR_ELT(Out, HEAD, tOut); #endif #ifdef COORDS #ifdef ZCOORD SET_VECTOR_ELT(Out, HEAD+NECK, xiOut); SET_VECTOR_ELT(Out, HEAD+NECK+1, yiOut); SET_VECTOR_ELT(Out, HEAD+NECK+2, ziOut); SET_VECTOR_ELT(Out, HEAD+NECK+3, xjOut); SET_VECTOR_ELT(Out, HEAD+NECK+4, yjOut); SET_VECTOR_ELT(Out, HEAD+NECK+5, zjOut); SET_VECTOR_ELT(Out, HEAD+NECK+6, dxOut); SET_VECTOR_ELT(Out, HEAD+NECK+7, dyOut); SET_VECTOR_ELT(Out, HEAD+NECK+8, dzOut); #else SET_VECTOR_ELT(Out, HEAD+NECK, xiOut); SET_VECTOR_ELT(Out, HEAD+NECK+1, yiOut); SET_VECTOR_ELT(Out, HEAD+NECK+2, xjOut); SET_VECTOR_ELT(Out, HEAD+NECK+3, yjOut); SET_VECTOR_ELT(Out, HEAD+NECK+4, dxOut); SET_VECTOR_ELT(Out, HEAD+NECK+5, dyOut); #endif #endif #ifdef DIST SET_VECTOR_ELT(Out, HEAD+NECK+MIDDLE, dOut); #endif UNPROTECT(NINPUTS+1+HEAD+NECK+MIDDLE+TAIL); /* 1 is for 'Out' itself */ return(Out); } #undef NINPUTS #undef HEAD #undef NECK #undef MIDDLE #undef TAIL /* ........................................................ */ SEXP CROSSFUN(SEXP xx1, SEXP yy1, #ifdef ZCOORD SEXP zz1, #endif SEXP xx2, SEXP yy2, #ifdef ZCOORD SEXP zz2, #endif SEXP rr, #ifdef THRESH SEXP ss, #endif SEXP nguess) { /* input vectors */ double *x1, *y1, *x2, *y2; #ifdef ZCOORD double *z1, *z2; #endif /* lengths */ int n1, n2, nout, noutmax, noutmaxold, maxchunk; /* distance parameter */ double rmax, r2max, rmaxplus; /* indices */ int i, j, jleft, m; /* temporary values */ double x1i, y1i, xleft, dx, dy, dx2, d2; #ifdef ZCOORD double z1i, dz; #endif /* local storage */ int *iout, *jout; /* R objects in return value */ SEXP Out, iOut, jOut; /* external storage pointers */ int *iOutP, *jOutP; #ifdef COORDS SEXP xiOut, yiOut, xjOut, yjOut, dxOut, dyOut; double *xiOutP, *yiOutP, *xjOutP, *yjOutP, *dxOutP, *dyOutP; double *xiout, *yiout, *xjout, *yjout, *dxout, *dyout; #ifdef ZCOORD SEXP ziOut, zjOut, dzOut; double *ziOutP, *zjOutP, *dzOutP; double *ziout, *zjout, *dzout; #endif #endif #ifdef DIST SEXP dOut; double *dOutP; double *dout; #endif #ifdef THRESH double s, s2; int *tout; SEXP tOut; int *tOutP; #endif /* protect R objects from garbage collector */ PROTECT(xx1 = AS_NUMERIC(xx1)); PROTECT(yy1 = AS_NUMERIC(yy1)); PROTECT(xx2 = AS_NUMERIC(xx2)); PROTECT(yy2 = AS_NUMERIC(yy2)); #ifdef ZCOORD PROTECT(zz1 = AS_NUMERIC(zz1)); PROTECT(zz2 = AS_NUMERIC(zz2)); #endif PROTECT(rr = AS_NUMERIC(rr)); PROTECT(nguess = AS_INTEGER(nguess)); #ifdef THRESH PROTECT(ss = AS_NUMERIC(ss)); #define NINPUTS (2*SPACEDIM + 3) #else #define NINPUTS (2*SPACEDIM + 2) #endif /* Translate arguments from R to C */ x1 = NUMERIC_POINTER(xx1); y1 = NUMERIC_POINTER(yy1); x2 = NUMERIC_POINTER(xx2); y2 = NUMERIC_POINTER(yy2); #ifdef ZCOORD z1 = NUMERIC_POINTER(zz1); z2 = NUMERIC_POINTER(zz2); #endif n1 = LENGTH(xx1); n2 = LENGTH(xx2); rmax = *(NUMERIC_POINTER(rr)); noutmax = *(INTEGER_POINTER(nguess)); r2max = rmax * rmax; rmaxplus = rmax + rmax/16.0; #ifdef THRESH s = *(NUMERIC_POINTER(ss)); s2 = s * s; #endif nout = 0; /* nout is the next available storage location and also the current length of the list */ if(n1 > 0 && n2 > 0 && noutmax > 0) { /* allocate space */ iout = (int *) R_alloc(noutmax, sizeof(int)); jout = (int *) R_alloc(noutmax, sizeof(int)); #ifdef COORDS xiout = (double *) R_alloc(noutmax, sizeof(double)); yiout = (double *) R_alloc(noutmax, sizeof(double)); xjout = (double *) R_alloc(noutmax, sizeof(double)); yjout = (double *) R_alloc(noutmax, sizeof(double)); dxout = (double *) R_alloc(noutmax, sizeof(double)); dyout = (double *) R_alloc(noutmax, sizeof(double)); #ifdef ZCOORD ziout = (double *) R_alloc(noutmax, sizeof(double)); zjout = (double *) R_alloc(noutmax, sizeof(double)); dzout = (double *) R_alloc(noutmax, sizeof(double)); #endif #endif #ifdef DIST dout = (double *) R_alloc(noutmax, sizeof(double)); #endif #ifdef THRESH tout = (int *) R_alloc(noutmax, sizeof(int)); #endif jleft = 0; i = 0; maxchunk = 0; while(i < n1) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > n1) maxchunk = n1; for( ; i < maxchunk; i++) { x1i = x1[i]; y1i = y1[i]; #ifdef ZCOORD z1i = z1[i]; #endif /* adjust starting point jleft */ xleft = x1i - rmaxplus; while((x2[jleft] < xleft) && (jleft+1 < n2)) ++jleft; /* process from j = jleft until dx > rmax + epsilon */ for(j=jleft; j < n2; j++) { /* squared interpoint distance */ dx = x2[j] - x1i; if(dx > rmaxplus) break; dx2 = dx * dx; dy = y2[j] - y1i; d2 = dx2 + dy * dy; #ifdef ZCOORD if(d2 <= r2max) { dz = z2[j] - z1i; d2 = d2 + dz * dz; #endif if(d2 <= r2max) { /* add this (i, j) pair to output */ if(nout >= noutmax) { /* overflow; allocate more space */ noutmaxold = noutmax; noutmax = 2 * noutmax; iout = intRealloc(iout, noutmaxold, noutmax); jout = intRealloc(jout, noutmaxold, noutmax); #ifdef COORDS xiout = dblRealloc(xiout, noutmaxold, noutmax); yiout = dblRealloc(yiout, noutmaxold, noutmax); xjout = dblRealloc(xjout, noutmaxold, noutmax); yjout = dblRealloc(yjout, noutmaxold, noutmax); dxout = dblRealloc(dxout, noutmaxold, noutmax); dyout = dblRealloc(dyout, noutmaxold, noutmax); #ifdef ZCOORD ziout = dblRealloc(ziout, noutmaxold, noutmax); zjout = dblRealloc(zjout, noutmaxold, noutmax); dzout = dblRealloc(dzout, noutmaxold, noutmax); #endif #endif #ifdef DIST dout = dblRealloc(dout, noutmaxold, noutmax); #endif #ifdef THRESH tout = intRealloc(tout, noutmaxold, noutmax); #endif } iout[nout] = i + 1; /* R indexing */ jout[nout] = j + 1; #ifdef COORDS xiout[nout] = x1i; yiout[nout] = y1i; xjout[nout] = x2[j]; yjout[nout] = y2[j]; dxout[nout] = dx; dyout[nout] = dy; #ifdef ZCOORD ziout[nout] = z1i; zjout[nout] = z2[j]; dzout[nout] = dz; #endif #endif #ifdef DIST dout[nout] = sqrt(d2); #endif #ifdef THRESH tout[nout] = (d2 <= s2) ? 1 : 0; #endif ++nout; } #ifdef ZCOORD } #endif } } } } /* return a list of vectors */ PROTECT(iOut = NEW_INTEGER(nout)); PROTECT(jOut = NEW_INTEGER(nout)); #ifdef COORDS PROTECT(xiOut = NEW_NUMERIC(nout)); PROTECT(yiOut = NEW_NUMERIC(nout)); PROTECT(xjOut = NEW_NUMERIC(nout)); PROTECT(yjOut = NEW_NUMERIC(nout)); PROTECT(dxOut = NEW_NUMERIC(nout)); PROTECT(dyOut = NEW_NUMERIC(nout)); #ifdef ZCOORD PROTECT(ziOut = NEW_NUMERIC(nout)); PROTECT(zjOut = NEW_NUMERIC(nout)); PROTECT(dzOut = NEW_NUMERIC(nout)); #endif #endif #ifdef DIST PROTECT(dOut = NEW_NUMERIC(nout)); #endif #ifdef THRESH PROTECT(tOut = NEW_INTEGER(nout)); #endif if(nout > 0) { iOutP = INTEGER_POINTER(iOut); jOutP = INTEGER_POINTER(jOut); #ifdef COORDS xiOutP = NUMERIC_POINTER(xiOut); yiOutP = NUMERIC_POINTER(yiOut); xjOutP = NUMERIC_POINTER(xjOut); yjOutP = NUMERIC_POINTER(yjOut); dxOutP = NUMERIC_POINTER(dxOut); dyOutP = NUMERIC_POINTER(dyOut); #ifdef ZCOORD ziOutP = NUMERIC_POINTER(ziOut); zjOutP = NUMERIC_POINTER(zjOut); dzOutP = NUMERIC_POINTER(dzOut); #endif #endif #ifdef DIST dOutP = NUMERIC_POINTER(dOut); #endif #ifdef THRESH tOutP = INTEGER_POINTER(tOut); #endif for(m = 0; m < nout; m++) { iOutP[m] = iout[m]; jOutP[m] = jout[m]; #ifdef COORDS xiOutP[m] = xiout[m]; yiOutP[m] = yiout[m]; xjOutP[m] = xjout[m]; yjOutP[m] = yjout[m]; dxOutP[m] = dxout[m]; dyOutP[m] = dyout[m]; #ifdef ZCOORD ziOutP[m] = ziout[m]; zjOutP[m] = zjout[m]; dzOutP[m] = dzout[m]; #endif #endif #ifdef DIST dOutP[m] = dout[m]; #endif #ifdef THRESH tOutP[m] = tout[m]; #endif } } #define HEAD 2 #ifdef THRESH #define NECK 1 #else #define NECK 0 #endif #ifdef COORDS #define MIDDLE (3*SPACEDIM) #else #define MIDDLE 0 #endif #ifdef DIST #define TAIL 1 #else #define TAIL 0 #endif PROTECT(Out = NEW_LIST(HEAD+NECK+MIDDLE+TAIL)); SET_VECTOR_ELT(Out, 0, iOut); SET_VECTOR_ELT(Out, 1, jOut); #ifdef THRESH SET_VECTOR_ELT(Out, HEAD, tOut); #endif #ifdef COORDS #ifdef ZCOORD SET_VECTOR_ELT(Out, HEAD+NECK, xiOut); SET_VECTOR_ELT(Out, HEAD+NECK+1, yiOut); SET_VECTOR_ELT(Out, HEAD+NECK+2, ziOut); SET_VECTOR_ELT(Out, HEAD+NECK+3, xjOut); SET_VECTOR_ELT(Out, HEAD+NECK+4, yjOut); SET_VECTOR_ELT(Out, HEAD+NECK+5, zjOut); SET_VECTOR_ELT(Out, HEAD+NECK+6, dxOut); SET_VECTOR_ELT(Out, HEAD+NECK+7, dyOut); SET_VECTOR_ELT(Out, HEAD+NECK+8, dzOut); #else SET_VECTOR_ELT(Out, HEAD+NECK, xiOut); SET_VECTOR_ELT(Out, HEAD+NECK+1, yiOut); SET_VECTOR_ELT(Out, HEAD+NECK+2, xjOut); SET_VECTOR_ELT(Out, HEAD+NECK+3, yjOut); SET_VECTOR_ELT(Out, HEAD+NECK+4, dxOut); SET_VECTOR_ELT(Out, HEAD+NECK+5, dyOut); #endif #endif #ifdef DIST SET_VECTOR_ELT(Out, HEAD+NECK+MIDDLE, dOut); #endif UNPROTECT(NINPUTS+1+HEAD+NECK+MIDDLE+TAIL); /* 1 is for 'Out' itself */ return(Out); } #undef NINPUTS #undef HEAD #undef NECK #undef MIDDLE #undef TAIL /* ........................................................ */ /* Alternative code for CLOSEFUN, based on algorithm in CROSSFUN */ #define ALT_ALGO(NAME) ALT_PREFIX(NAME) #define ALT_PREFIX(NAME) alt ## NAME SEXP ALT_ALGO(CLOSEFUN)(SEXP xx, SEXP yy, #ifdef ZCOORD SEXP zz, #endif SEXP rr, #ifdef THRESH SEXP ss, #endif SEXP nguess) { /* input vectors */ double *x, *y; #ifdef ZCOORD double *z; #endif /* lengths */ int n, nout, noutmax, noutmaxold, maxchunk; /* distance parameter */ double rmax, r2max, rmaxplus; /* indices */ int i, j, jleft, m; /* temporary values */ double xi, yi, xleft, dx, dy, dx2, d2; #ifdef ZCOORD double zi, dz; #endif /* local storage */ int *iout, *jout; /* R objects in return value */ SEXP Out, iOut, jOut; /* external storage pointers */ int *iOutP, *jOutP; #ifdef COORDS SEXP xiOut, yiOut, xjOut, yjOut, dxOut, dyOut; double *xiOutP, *yiOutP, *xjOutP, *yjOutP, *dxOutP, *dyOutP; double *xiout, *yiout, *xjout, *yjout, *dxout, *dyout; #ifdef ZCOORD SEXP ziOut, zjOut, dzOut; double *ziOutP, *zjOutP, *dzOutP; double *ziout, *zjout, *dzout; #endif #endif #ifdef DIST SEXP dOut; double *dOutP; double *dout; #endif #ifdef THRESH double s, s2; int *tout; SEXP tOut; int *tOutP; #endif /* protect R objects from garbage collector */ PROTECT(xx = AS_NUMERIC(xx)); PROTECT(yy = AS_NUMERIC(yy)); #ifdef ZCOORD PROTECT(zz = AS_NUMERIC(zz)); #endif PROTECT(rr = AS_NUMERIC(rr)); PROTECT(nguess = AS_INTEGER(nguess)); #ifdef THRESH PROTECT(ss = AS_NUMERIC(ss)); #define NINPUTS (SPACEDIM + 3) #else #define NINPUTS (SPACEDIM + 2) #endif /* Translate arguments from R to C */ x = NUMERIC_POINTER(xx); y = NUMERIC_POINTER(yy); #ifdef ZCOORD z = NUMERIC_POINTER(zz); #endif n = LENGTH(xx); rmax = *(NUMERIC_POINTER(rr)); noutmax = *(INTEGER_POINTER(nguess)); r2max = rmax * rmax; rmaxplus = rmax + rmax/16.0; #ifdef THRESH s = *(NUMERIC_POINTER(ss)); s2 = s * s; #endif nout = 0; /* nout is the next available storage location and also the current length of the list */ if(n > 0 && noutmax > 0) { /* allocate space */ iout = (int *) R_alloc(noutmax, sizeof(int)); jout = (int *) R_alloc(noutmax, sizeof(int)); #ifdef COORDS xiout = (double *) R_alloc(noutmax, sizeof(double)); yiout = (double *) R_alloc(noutmax, sizeof(double)); xjout = (double *) R_alloc(noutmax, sizeof(double)); yjout = (double *) R_alloc(noutmax, sizeof(double)); dxout = (double *) R_alloc(noutmax, sizeof(double)); dyout = (double *) R_alloc(noutmax, sizeof(double)); #ifdef ZCOORD ziout = (double *) R_alloc(noutmax, sizeof(double)); zjout = (double *) R_alloc(noutmax, sizeof(double)); dzout = (double *) R_alloc(noutmax, sizeof(double)); #endif #endif #ifdef DIST dout = (double *) R_alloc(noutmax, sizeof(double)); #endif #ifdef THRESH tout = (int *) R_alloc(noutmax, sizeof(int)); #endif jleft = 0; i = 0; maxchunk = 0; while(i < n) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > n) maxchunk = n; for( ; i < maxchunk; i++) { xi = x[i]; yi = y[i]; #ifdef ZCOORD zi = z[i]; #endif /* adjust starting point jleft */ xleft = xi - rmaxplus; while((x[jleft] < xleft) && (jleft+1 < n)) ++jleft; /* process from j = jleft until dx > rmax + epsilon */ for(j=jleft; j < n; j++) { /* squared interpoint distance */ dx = x[j] - xi; if(dx > rmaxplus) break; dx2 = dx * dx; dy = y[j] - yi; d2 = dx2 + dy * dy; #ifdef ZCOORD if(d2 <= r2max) { dz = z[j] - zi; d2 = d2 + dz * dz; #endif if(d2 <= r2max) { /* add this (i, j) pair to output */ if(nout >= noutmax) { /* overflow; allocate more space */ noutmaxold = noutmax; noutmax = 2 * noutmax; iout = intRealloc(iout, noutmaxold, noutmax); jout = intRealloc(jout, noutmaxold, noutmax); #ifdef COORDS xiout = dblRealloc(xiout, noutmaxold, noutmax); yiout = dblRealloc(yiout, noutmaxold, noutmax); xjout = dblRealloc(xjout, noutmaxold, noutmax); yjout = dblRealloc(yjout, noutmaxold, noutmax); dxout = dblRealloc(dxout, noutmaxold, noutmax); dyout = dblRealloc(dyout, noutmaxold, noutmax); #ifdef ZCOORD ziout = dblRealloc(ziout, noutmaxold, noutmax); zjout = dblRealloc(zjout, noutmaxold, noutmax); dzout = dblRealloc(dzout, noutmaxold, noutmax); #endif #endif #ifdef DIST dout = dblRealloc(dout, noutmaxold, noutmax); #endif #ifdef THRESH tout = intRealloc(tout, noutmaxold, noutmax); #endif } iout[nout] = i + 1; /* R indexing */ jout[nout] = j + 1; #ifdef COORDS xiout[nout] = xi; yiout[nout] = yi; xjout[nout] = x[j]; yjout[nout] = y[j]; dxout[nout] = dx; dyout[nout] = dy; #ifdef ZCOORD ziout[nout] = zi; zjout[nout] = z[j]; dzout[nout] = dz; #endif #endif #ifdef DIST dout[nout] = sqrt(d2); #endif #ifdef THRESH tout[nout] = (d2 <= s2) ? 1 : 0; #endif ++nout; } #ifdef ZCOORD } #endif } } } } /* return a list of vectors */ PROTECT(iOut = NEW_INTEGER(nout)); PROTECT(jOut = NEW_INTEGER(nout)); #ifdef COORDS PROTECT(xiOut = NEW_NUMERIC(nout)); PROTECT(yiOut = NEW_NUMERIC(nout)); PROTECT(xjOut = NEW_NUMERIC(nout)); PROTECT(yjOut = NEW_NUMERIC(nout)); PROTECT(dxOut = NEW_NUMERIC(nout)); PROTECT(dyOut = NEW_NUMERIC(nout)); #ifdef ZCOORD PROTECT(ziOut = NEW_NUMERIC(nout)); PROTECT(zjOut = NEW_NUMERIC(nout)); PROTECT(dzOut = NEW_NUMERIC(nout)); #endif #endif #ifdef DIST PROTECT(dOut = NEW_NUMERIC(nout)); #endif #ifdef THRESH PROTECT(tOut = NEW_INTEGER(nout)); #endif if(nout > 0) { iOutP = INTEGER_POINTER(iOut); jOutP = INTEGER_POINTER(jOut); #ifdef COORDS xiOutP = NUMERIC_POINTER(xiOut); yiOutP = NUMERIC_POINTER(yiOut); xjOutP = NUMERIC_POINTER(xjOut); yjOutP = NUMERIC_POINTER(yjOut); dxOutP = NUMERIC_POINTER(dxOut); dyOutP = NUMERIC_POINTER(dyOut); #ifdef ZCOORD ziOutP = NUMERIC_POINTER(ziOut); zjOutP = NUMERIC_POINTER(zjOut); dzOutP = NUMERIC_POINTER(dzOut); #endif #endif #ifdef DIST dOutP = NUMERIC_POINTER(dOut); #endif #ifdef THRESH tOutP = INTEGER_POINTER(tOut); #endif for(m = 0; m < nout; m++) { iOutP[m] = iout[m]; jOutP[m] = jout[m]; #ifdef COORDS xiOutP[m] = xiout[m]; yiOutP[m] = yiout[m]; xjOutP[m] = xjout[m]; yjOutP[m] = yjout[m]; dxOutP[m] = dxout[m]; dyOutP[m] = dyout[m]; #ifdef ZCOORD ziOutP[m] = ziout[m]; zjOutP[m] = zjout[m]; dzOutP[m] = dzout[m]; #endif #endif #ifdef DIST dOutP[m] = dout[m]; #endif #ifdef THRESH tOutP[m] = tout[m]; #endif } } #define HEAD 2 #ifdef THRESH #define NECK 1 #else #define NECK 0 #endif #ifdef COORDS #define MIDDLE (3*SPACEDIM) #else #define MIDDLE 0 #endif #ifdef DIST #define TAIL 1 #else #define TAIL 0 #endif PROTECT(Out = NEW_LIST(HEAD+NECK+MIDDLE+TAIL)); SET_VECTOR_ELT(Out, 0, iOut); SET_VECTOR_ELT(Out, 1, jOut); #ifdef THRESH SET_VECTOR_ELT(Out, HEAD, tOut); #endif #ifdef COORDS #ifdef ZCOORD SET_VECTOR_ELT(Out, HEAD+NECK, xiOut); SET_VECTOR_ELT(Out, HEAD+NECK+1, yiOut); SET_VECTOR_ELT(Out, HEAD+NECK+2, ziOut); SET_VECTOR_ELT(Out, HEAD+NECK+3, xjOut); SET_VECTOR_ELT(Out, HEAD+NECK+4, yjOut); SET_VECTOR_ELT(Out, HEAD+NECK+5, zjOut); SET_VECTOR_ELT(Out, HEAD+NECK+6, dxOut); SET_VECTOR_ELT(Out, HEAD+NECK+7, dyOut); SET_VECTOR_ELT(Out, HEAD+NECK+8, dzOut); #else SET_VECTOR_ELT(Out, HEAD+NECK, xiOut); SET_VECTOR_ELT(Out, HEAD+NECK+1, yiOut); SET_VECTOR_ELT(Out, HEAD+NECK+2, xjOut); SET_VECTOR_ELT(Out, HEAD+NECK+3, yjOut); SET_VECTOR_ELT(Out, HEAD+NECK+4, dxOut); SET_VECTOR_ELT(Out, HEAD+NECK+5, dyOut); #endif #endif #ifdef DIST SET_VECTOR_ELT(Out, HEAD+NECK+MIDDLE, dOut); #endif UNPROTECT(NINPUTS+1+HEAD+NECK+MIDDLE+TAIL); /* 1 is for 'Out' itself */ return(Out); } #undef NINPUTS #undef HEAD #undef NECK #undef MIDDLE #undef TAIL #undef ALT_ALGO #undef ALT_PREFIX spatstat.geom/src/metricPdist.h0000644000176200001440000001107614611065353016303 0ustar liggesusers/* metricPdist.h Distance transform of a discrete binary image using a general metric Code template which is #included several times in metricPdist.c $Revision: 1.7 $ $Date: 2022/10/21 10:43:01 $ Uses the following definitions FNAME Function name (called from R) MARGLIST List of function arguments specifying the metric MTEMPDECLARE Declaration and initialisation of variables for metric METRIC Expression for calculating the metric (x1,y1,x2,y2) Also uses definitions from raster.h and metricPdist.c Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ void FNAME( double *xmin, double *ymin, double *xmax, double *ymax, /* range of coords of grid points */ /* WARNING: the enclosing frame is larger than xmin, xmax, ymin, ymax */ int *nr, int *nc, /* raster dimensions EXCLUDING margins */ int *mr, int *mc, /* margins */ int *inp, /* input: binary image */ MARGLIST, int *npasses, /* number of passes over raster */ double *distances, /* output: distance to nearest point */ int *rows, /* output: row of nearest point (start= 0) */ int *cols /* output: column of nearest point (start = 0) */ /* all images must have identical dimensions including a margin of 1 on each side */ ) { Raster data, dist, row, col; int mrow, mcol, nrow, ncol; int j,k; double d, x, y; int r, c; int Npass, ipass; int changed; double dnew, diam, dd, huge; double Xmin, Ymin, Xmax, Ymax; /* declare any variables used for the metric */ MTEMPDECLARE; Xmin = *xmin; Xmax = *xmax; Ymin = *ymin; Ymax = *ymax; mrow = *mr; mcol = *mc; Npass = *npasses; /* Determine diameter of window. (must be achieved as distance between two of the vertices) */ /* diagonals */ diam = METRIC(Xmin,Ymin,Xmax,Ymax); dd = METRIC(Xmin,Ymax,Xmax,Ymin); if(dd > diam) diam = dd; dd = METRIC(Xmin,Ymin,Xmin,Ymax); if(dd > diam) diam = dd; /* horizontals */ dd = METRIC(Xmin,Ymin,Xmax,Ymin); if(dd > diam) diam = dd; dd = METRIC(Xmin,Ymax,Xmax,Ymax); if(dd > diam) diam = dd; /* verticals */ dd = METRIC(Xmin,Ymin,Xmin,Ymax); if(dd > diam) diam = dd; dd = METRIC(Xmax,Ymin,Xmax,Ymax); if(dd > diam) diam = dd; /* create raster structures */ /* full dimensions */ nrow = *nr + 2 * mrow; ncol = *nc + 2 * mcol; shape_raster( &data, (void *) inp, Xmin, Ymin, Xmax, Ymax, nrow, ncol, mrow, mcol); shape_raster( &dist, (void *) distances, Xmin, Ymin, Xmax, Ymax, nrow, ncol, mrow, mcol); shape_raster( &row, (void *) rows, Xmin, Ymin, Xmax, Ymax, nrow, ncol, mrow, mcol); shape_raster( &col, (void *) cols, Xmin, Ymin, Xmax, Ymax, nrow, ncol, mrow, mcol); /* initialise arrays */ Clear(row,int,UNDEFINED) Clear(col,int,UNDEFINED) huge = 2.0 * diam; Clear(dist,double,huge) /* if input pixel is TRUE, set distance to 0 and make pixel point to itself */ for(j = data.rmin; j <= data.rmax; j++) { for(k = data.cmin; k <= data.cmax; k++) { if(Entry(data, j, k, int) != 0) { Entry(dist, j, k, double) = 0.0; Entry(row, j, k, int) = j; Entry(col, j, k, int) = k; } } } /* how to update the distance values */ #undef GETVALUES #define GETVALUES(ROW,COL) \ x = Xpos(data, COL); \ y = Ypos(data, ROW); \ d = Entry(dist,ROW,COL,double) #undef COMPARE #define COMPARE(ROW,COL,RR,CC) \ r = Entry(row,RR,CC,int); \ c = Entry(col,RR,CC,int); \ if(Is_Defined(r) && Is_Defined(c) \ && Entry(dist,RR,CC,double) < d) { \ dnew = METRIC(x, y, Xpos(data,c), Ypos(data,r)); \ if(dnew < d) { \ changed = 1; \ Entry(row,ROW,COL,int) = r; \ Entry(col,ROW,COL,int) = c; \ Entry(dist,ROW,COL,double) = dnew; \ d = dnew; \ } \ } for(ipass = 0; ipass < Npass; ipass++) { changed = 0; /* forward pass */ for(j = data.rmin; j <= data.rmax; j++) { for(k = data.cmin; k <= data.cmax; k++) { GETVALUES(j, k); if(d > 0) { COMPARE(j,k, j-1,k-1) COMPARE(j,k, j-1, k) COMPARE(j,k, j-1,k+1) COMPARE(j,k, j, k-1) } } } /* backward pass */ for(j = data.rmax; j >= data.rmin; j--) { for(k = data.cmax; k >= data.cmin; k--) { GETVALUES(j, k); if(d > 0) { COMPARE(j,k, j+1,k+1) COMPARE(j,k, j+1, k) COMPARE(j,k, j+1,k-1) COMPARE(j,k, j, k+1) } } } /* check for convergence */ if(changed == 0) return; } } spatstat.geom/src/quasirandom.c0000644000176200001440000000103514611065353016324 0ustar liggesusers/* quasirandom.c Quasi-random sequence generators Copyright (C) Adrian Baddeley 2014 GNU Public Licence version 2 | 3 $Revision: 1.3 $ $Date: 2022/10/22 02:51:11 $ */ #include void Corput( int *base, int *n, double *result ) { int b, N, i, j; register double f, f0, z; N = *n; b = *base; f0 = 1.0/((double) b); for(i = 0; i < N; i++) { j = i+1; z = 0; f = f0; while(j > 0) { z = z + f * (j % b); j = j/b; f = f / ((double) b); } result[i] = z; } } spatstat.geom/src/distan3.c0000644000176200001440000002601014611065353015346 0ustar liggesusers/* distan3.c Distances between pairs of 3D points $Revision: 1.8 $ $Date: 2022/10/22 09:29:51 $ D3pairdist Pairwise distances D3pair2dist Pairwise distances squared D3pairPdist Pairwise distances with periodic correction D3pairP2dist Pairwise distances squared, with periodic correction D3crossdist Pairwise distances for two sets of points D3cross2dist Pairwise distances squared, for two sets of points D3crossPdist Pairwise distances for two sets of points, periodic correction matchxyz Find matches between two sets of points Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include /* #include */ double sqrt(double x); void D3pairdist( /* inputs */ int *n, double *x, double *y, double *z, int *squared, /* output */ double *d ) { void D3pair1dist(int *n, double *x, double *y, double *z, double *d); void D3pair2dist(int *n, double *x, double *y, double *z, double *d); if(*squared == 0) { D3pair1dist(n, x, y, z, d); } else { D3pair2dist(n, x, y, z, d); } } void D3pair1dist( /* inputs */ int *n, double *x, double *y, double *z, /* output */ double *d ) { int i, j, npoints; double *dp; double xi, yi, zi, dx, dy, dz, dist; npoints = *n; /* set d[0,0] = 0 */ *d = 0.0; for (i=1; i < npoints; i++) { xi = x[i]; yi = y[i]; zi = z[i]; /* point at the start of column i */ dp = d + i * npoints; /* set diagonal to zero */ dp[i] = 0.0; for (j=0; j < i; j++) { dx = x[j] - xi; dy = y[j] - yi; dz = z[j] - zi; dist = sqrt( dx * dx + dy * dy + dz * dz ); /* upper triangle */ *dp = dist; ++dp; /* lower triangle */ d[ j * npoints + i] = dist; } } } /* squared distances */ void D3pair2dist( /* inputs */ int *n, double *x, double *y, double *z, /* output */ double *d ) { int i, j, npoints; double *dp; double xi, yi, zi, dx, dy, dz, dist; npoints = *n; /* set d[0,0] = 0 */ *d = 0.0; for (i=1; i < npoints; i++) { xi = x[i]; yi = y[i]; zi = z[i]; /* point at the start of column i */ dp = d + i * npoints; /* set diagonal to zero */ dp[i] = 0.0; for (j=0; j < i; j++) { dx = x[j] - xi; dy = y[j] - yi; dz = z[j] - zi; dist = dx * dx + dy * dy + dz * dz; /* upper triangle */ *dp = dist; ++dp; /* lower triangle */ d[ j * npoints + i] = dist; } } } void D3crossdist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, int *squared, /* output */ double *d ) { void D3cross1dist(int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, double *d); void D3cross2dist(int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, double *d); if(*squared == 0) { D3cross1dist(nfrom, xfrom, yfrom, zfrom, nto, xto, yto, zto, d); } else { D3cross2dist(nfrom, xfrom, yfrom, zfrom, nto, xto, yto, zto, d); } } void D3cross1dist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, /* output */ double *d ) { int i, j, nf, nt; double *dptr; double xj, yj, zj, dx, dy, dz; nf = *nfrom; nt = *nto; dptr = d; for (j=0; j < nt; j++) { xj = xto[j]; yj = yto[j]; zj = zto[j]; for(i = 0; i < nf; i++, dptr++) { dx = xj - xfrom[i]; dy = yj - yfrom[i]; dz = zj - zfrom[i]; *dptr = sqrt( dx * dx + dy * dy + dz * dz ); } } } /* squared distances */ void D3cross2dist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, /* output */ double *d ) { int i, j, nf, nt; double *dptr; double xj, yj, zj, dx, dy, dz; nf = *nfrom; nt = *nto; dptr = d; for (j=0; j < nt; j++) { xj = xto[j]; yj = yto[j]; zj = zto[j]; for(i = 0; i < nf; i++, dptr++) { dx = xj - xfrom[i]; dy = yj - yfrom[i]; dz = zj - zfrom[i]; *dptr = dx * dx + dy * dy + dz * dz; } } } /* distances with periodic correction */ void D3pairPdist( /* inputs */ int *n, double *x, double *y, double *z, double *xwidth, double *yheight, double *zdepth, int *squared, /* output */ double *d ) { void D3pairP1dist(int *n, double *x, double *y, double *z, double *xwidth, double *yheight, double *zdepth, double *d); void D3pairP2dist(int *n, double *x, double *y, double *z, double *xwidth, double *yheight, double *zdepth, double *d); if(*squared == 0) { D3pairP1dist(n, x, y, z, xwidth, yheight, zdepth, d); } else { D3pairP2dist(n, x, y, z, xwidth, yheight, zdepth, d); } } void D3pairP1dist( /* inputs */ int *n, double *x, double *y, double *z, double *xwidth, double *yheight, double *zdepth, /* output */ double *d ) { int i, j, npoints; double *dp; double xi, yi, zi, dx, dy, dz, dx2, dy2, dz2, dx2p, dy2p, dz2p, dist, wide, high, deep; npoints = *n; wide = *xwidth; high = *yheight; deep = *zdepth; /* set d[0,0] = 0 */ *d = 0.0; for (i=1; i < npoints; i++) { xi = x[i]; yi = y[i]; zi = z[i]; /* point at the start of column i */ dp = d + i * npoints; /* set diagonal to zero */ dp[i] = 0.0; for (j=0; j < i; j++) { dx = x[j] - xi; dy = y[j] - yi; dz = z[j] - zi; dx2p = dx * dx; dy2p = dy * dy; dz2p = dz * dz; dx2 = (dx - wide) * (dx - wide); dy2 = (dy - high) * (dy - high); dz2 = (dz - deep) * (dz - deep); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; if(dz2 < dz2p) dz2p = dz2; dx2 = (dx + wide) * (dx + wide); dy2 = (dy + high) * (dy + high); dz2 = (dz + deep) * (dz + deep); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; if(dz2 < dz2p) dz2p = dz2; dist = sqrt( dx2p + dy2p + dz2p ); /* upper triangle */ *dp = dist; ++dp; /* lower triangle */ d[ j * npoints + i] = dist; } } } /* same function without the sqrt */ void D3pairP2dist( /* inputs */ int *n, double *x, double *y, double *z, double *xwidth, double *yheight, double *zdepth, /* output */ double *d ) { int i, j, npoints; double *dp; double xi, yi, zi, dx, dy, dz, dx2, dy2, dz2, dx2p, dy2p, dz2p, dist, wide, high, deep; npoints = *n; wide = *xwidth; high = *yheight; deep = *zdepth; /* set d[0,0] = 0 */ *d = 0.0; for (i=1; i < npoints; i++) { xi = x[i]; yi = y[i]; zi = z[i]; /* point at the start of column i */ dp = d + i * npoints; /* set diagonal to zero */ dp[i] = 0.0; for (j=0; j < i; j++) { dx = x[j] - xi; dy = y[j] - yi; dz = z[j] - zi; dx2p = dx * dx; dy2p = dy * dy; dz2p = dz * dz; dx2 = (dx - wide) * (dx - wide); dy2 = (dy - high) * (dy - high); dz2 = (dz - deep) * (dz - deep); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; if(dz2 < dz2p) dz2p = dz2; dx2 = (dx + wide) * (dx + wide); dy2 = (dy + high) * (dy + high); dz2 = (dz + deep) * (dz + deep); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; if(dz2 < dz2p) dz2p = dz2; dist = dx2p + dy2p + dz2p; /* upper triangle */ *dp = dist; ++dp; /* lower triangle */ d[ j * npoints + i] = dist; } } } void D3crossPdist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, double *xwidth, double *yheight, double *zdepth, int *squared, /* output */ double *d ) { void D3crossP1dist(int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, double *xwidth, double *yheight, double *zdepth, double *d); void D3crossP2dist(int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, double *xwidth, double *yheight, double *zdepth, double *d); if(*squared == 0) { D3crossP1dist(nfrom, xfrom, yfrom, zfrom, nto, xto, yto, zto, xwidth, yheight, zdepth, d); } else { D3crossP2dist(nfrom, xfrom, yfrom, zfrom, nto, xto, yto, zto, xwidth, yheight, zdepth, d); } } void D3crossP1dist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, double *xwidth, double *yheight, double *zdepth, /* output */ double *d ) { int i, j, nf, nt; double *dptr; double xj, yj, zj, dx, dy, dz, dx2, dy2, dz2, dx2p, dy2p, dz2p, wide, high, deep; nf = *nfrom; nt = *nto; wide = *xwidth; high = *yheight; deep = *zdepth; dptr = d; for (j=0; j < nt; j++) { xj = xto[j]; yj = yto[j]; zj = zto[j]; for(i = 0; i < nf; i++, dptr++) { dx = xj - xfrom[i]; dy = yj - yfrom[i]; dz = zj - zfrom[i]; dx2p = dx * dx; dy2p = dy * dy; dz2p = dz * dz; dx2 = (dx - wide) * (dx - wide); dy2 = (dy - high) * (dy - high); dz2 = (dz - deep) * (dz - deep); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; if(dz2 < dz2p) dz2p = dz2; dx2 = (dx + wide) * (dx + wide); dy2 = (dy + high) * (dy + high); dz2 = (dz + deep) * (dz + deep); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; if(dz2 < dz2p) dz2p = dz2; *dptr = sqrt( dx2p + dy2p + dz2p ); } } } void D3crossP2dist( /* inputs */ int *nfrom, double *xfrom, double *yfrom, double *zfrom, int *nto, double *xto, double *yto, double *zto, double *xwidth, double *yheight, double *zdepth, /* output */ double *d ) { int i, j, nf, nt; double *dptr; double xj, yj, zj, dx, dy, dz, dx2, dy2, dz2, dx2p, dy2p, dz2p, wide, high, deep; nf = *nfrom; nt = *nto; wide = *xwidth; high = *yheight; deep = *zdepth; dptr = d; for (j=0; j < nt; j++) { xj = xto[j]; yj = yto[j]; zj = zto[j]; for(i = 0; i < nf; i++, dptr++) { dx = xj - xfrom[i]; dy = yj - yfrom[i]; dz = zj - zfrom[i]; dx2p = dx * dx; dy2p = dy * dy; dz2p = dz * dz; dx2 = (dx - wide) * (dx - wide); dy2 = (dy - high) * (dy - high); dz2 = (dz - deep) * (dz - deep); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; if(dz2 < dz2p) dz2p = dz2; dx2 = (dx + wide) * (dx + wide); dy2 = (dy + high) * (dy + high); dz2 = (dz + deep) * (dz + deep); if(dx2 < dx2p) dx2p = dx2; if(dy2 < dy2p) dy2p = dy2; if(dz2 < dz2p) dz2p = dz2; *dptr = dx2p + dy2p + dz2p; } } } /* matchxyz Find matches between two lists of points */ void matchxyz( /* inputs */ int *na, double *xa, double *ya, double *za, int *nb, double *xb, double *yb, double *zb, /* output */ int *match ) { int i, j, Na, Nb; double xai, yai, zai; Na = *na; Nb = *nb; for (i=1; i < Na; i++) { xai = xa[i]; yai = ya[i]; zai = za[i]; match[i] = 0; for (j=0; j < Nb; j++) if(xai == xb[j] && yai == yb[j] && zai == zb[i]) { match[i] = j; break; } } } spatstat.geom/src/nndistX.h0000644000176200001440000000645714611065353015452 0ustar liggesusers #if (1 == 0) /* nndistX.h Code template for C functions supporting nncross THE FOLLOWING CODE ASSUMES THAT LISTS ARE SORTED IN ASCENDING ORDER OF y COORDINATE This code is #included multiple times in nndistance.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour EXCLUDE #defined if exclusion mechanism is used Either or both DIST and WHICH may be defined. When EXCLUDE is defined, code numbers id1, id2 are attached to the patterns X and Y respectively, such that x1[i], y1[i] and x2[j], y2[j] are the same point iff id1[i] = id2[j]. Copyright (C) Adrian Baddeley, Jens Oehlschlagel and Rolf Turner 2000-2012 Licence: GPL >= 2 $Revision: 1.9 $ $Date: 2024/02/02 08:17:46 $ */ #endif #undef USEJ #if ((defined WHICH) | (!defined EXCLUDE)) #define USEJ #endif void FNAME( int *n1, double *x1, double *y1, int *id1, int *n2, double *x2, double *y2, int *id2, double *nnd, int *nnwhich, double *huge /* some inputs + outputs are not used in all functions */ ) { int npoints1, npoints2, maxchunk, i, jleft, jright, lastjwhich; double d2, d2min, x1i, y1i, dx, dy, dy2; double hu, hu2; #ifdef USEJ int jwhich; #endif #ifdef EXCLUDE int id1i; #endif hu = *huge; hu2 = hu * hu; npoints1 = *n1; npoints2 = *n2; if(npoints1 == 0 || npoints2 == 0) return; lastjwhich = 0; /* remains unchanged if EXCLUDE is defined */ /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < npoints1) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > npoints1) maxchunk = npoints1; for(; i < maxchunk; i++) { d2min = hu2; x1i = x1[i]; y1i = y1[i]; #ifdef EXCLUDE id1i = id1[i]; #endif #ifdef USEJ jwhich = -1; #endif if(lastjwhich < npoints2) { /* always true if EXCLUDE is defined */ /* search forward from previous nearest neighbour */ for(jright = lastjwhich; jright < npoints2; ++jright) { dy = y2[jright] - y1i; dy2 = dy * dy; if(dy2 > d2min) /* note that dy2 >= d2min could break too early */ break; #ifdef EXCLUDE /* do not compare identical points */ if(id2[jright] != id1i) { #endif dx = x2[jright] - x1i; d2 = dx * dx + dy2; if (d2 < d2min) { d2min = d2; #ifdef USEJ jwhich = jright; #endif } #ifdef EXCLUDE } #endif } /* end forward search */ } if(lastjwhich > 0) { /* always false if EXCLUDE is defined */ /* search backward from previous nearest neighbour */ for(jleft = lastjwhich - 1; jleft >= 0; --jleft) { dy = y1i - y2[jleft]; dy2 = dy * dy; if(dy2 > d2min) /* note that dy2 >= d2min could break too early */ break; #ifdef EXCLUDE /* do not compare identical points */ if(id2[jleft] != id1i) { #endif dx = x2[jleft] - x1i; d2 = dx * dx + dy2; if (d2 < d2min) { d2min = d2; #ifdef USEJ jwhich = jleft; #endif } #ifdef EXCLUDE } #endif } /* end backward search */ } /* commit values */ #ifdef DIST nnd[i] = sqrt(d2min); #endif #ifdef WHICH nnwhich[i] = jwhich + 1; /* R indexing */ #endif #ifndef EXCLUDE lastjwhich = jwhich; #endif } } } spatstat.geom/src/dist2dpath.c0000644000176200001440000000070114611065353016046 0ustar liggesusers#include #include /* given matrix of edge lengths compute matrix of shortest-path distances Uses dist2dpath.h Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #define FNAME Ddist2dpath #define DTYPE double #define FLOATY #include "dist2dpath.h" #undef FNAME #undef DTYPE #undef FLOATY #define FNAME Idist2dpath #define DTYPE int #include "dist2dpath.h" spatstat.geom/src/constants.h0000644000176200001440000000074714611065353016033 0ustar liggesusers/* constants.h Ensure that required constants are defined (Insurance against flaky installations) $Revision: 1.2 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #ifndef M_PI #define M_PI 3.141592653589793 #endif #ifndef M_PI_2 #define M_PI_2 1.570796326794897 #endif #ifndef M_2_PI #define M_2_PI (2.0/M_PI) #endif #ifndef M_2PI #define M_2PI 6.283185307179586 #endif spatstat.geom/src/seg2pix.c0000644000176200001440000001452214611065353015367 0ustar liggesusers#include #include #include #include #include "chunkloop.h" #undef DEBUG /* seg2pix.c Discretise line segment on pixel grid seg2pixI pixel value is indicator = 1 if any line crosses pixel seg2pixN pixel value is (weighted) number of lines crossing pixel seg2pixL pixel value is total (weighted) length of lines inside pixel (rescale R data so that pixels are integer) pixels numbered 0, ..., nx-1 and 0, ..., ny-1 with boundaries at x=0, x=nx, y=0, y=ny. Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #define V(I,J) out[(I) + (J) * (Ny)] int clamp( int k, int n0, int n1 ) { int m; m = k; if(m < n0) m = n0; if(m > n1) m = n1; return(m); } /* function 'seg2pixI' returns indicator = 1 if pixel is hit by any segment */ #define FNAME seg2pixI #undef SUMUP #include "seg2pix.h" #undef FNAME /* function 'seg2pixN' returns (weighted) number of segments hitting pixel */ #define FNAME seg2pixN #define SUMUP #include "seg2pix.h" #undef FNAME #undef SUMUP /* the other one is anomalous... */ void seg2pixL( int *ns, double *x0, double *y0, double *x1, double *y1, double *weights, /* segment coordinates and weights */ double *pixwidth, double *pixheight, /* original pixel dimensions */ int *nx, int *ny, double *out /* output matrix */ ) { int Ns, Nx, Ny, i, j, k, m, mmin, mmax, maxchunk; double x0i, x1i, y0i, y1i; double leni; double xleft, yleft, xright, yright, slope, scalesecant; double xlow, xhigh, ylow, yhigh, invslope, scalecosecant; double xstart, ystart, xfinish, yfinish; double xxx0, xxx1, yyy0, yyy1; int mleft, mright, kstart, kfinish, kmin, kmax; double pwidth, pheight, pwidth2, pheight2; double wti; Ns = *ns; Nx = *nx; Ny = *ny; /* one scaled x unit = 'pwidth' original x units one scaled y unit = 'pheight' original y units */ pwidth = *pixwidth; pheight = *pixheight; pwidth2 = pwidth * pwidth; pheight2 = pheight * pheight; /* zero the matrix */ for(k = 0; k < Ny - 1; k++) for(j = 0; j < Nx - 1; j++) V(k, j) = 0; OUTERCHUNKLOOP(i, Ns, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, Ns, maxchunk, 8196) { x0i = x0[i]; y0i = y0[i]; x1i = x1[i]; y1i = y1[i]; wti = weights[i]; leni = sqrt(pwidth2 * pow(x1i - x0i, 2) + pheight2 * pow(y1i-y0i, 2)); #ifdef DEBUG Rprintf("(%lf, %lf) to (%lf, %lf), length %lf\n", x0i, y0i, x1i, y1i, leni); #endif if(leni < 0.001) { /* tiny segment */ #ifdef DEBUG Rprintf("tiny\n"); #endif k = clamp((int) floor(x0i), 0, Nx-1); j = clamp((int) floor(y0i), 0, Ny-1); V(j,k) += wti * leni; } else if(floor(x1i) == floor(x0i) && floor(y1i) == floor(y0i)) { /* contained in one cell */ #ifdef DEBUG Rprintf("contained in one cell\n"); #endif k = clamp((int) floor(x0i), 0, Nx-1); j = clamp((int) floor(y0i), 0, Ny-1); V(j,k) += wti * leni; } else if(floor(y1i) == floor(y0i)) { /* horizontal */ #ifdef DEBUG Rprintf("horizontal\n"); #endif j = clamp((int) floor(y1i), 0, Ny-1); if(x1i > x0i) { xleft = x0i; yleft = y0i; xright = x1i; yright = y1i; } else { xleft = x1i; yleft = y1i; xright = x0i; yright = y0i; } mmin = clamp((int) floor(xleft), 0, Nx-1); mmax = clamp((int) floor(xright), 0, Nx-1); slope = (yright - yleft)/(xright - xleft); scalesecant = wti * sqrt(pwidth2 + slope * slope * pheight2); /* For this slope, one scaled x unit means 'pwidth' original x units and slope * pheight original y units i.e. line length sqrt(pwidth^2 + slope^2 * pheight^2) */ for(k = mmin; k <= mmax; k++) { xstart = (k == mmin) ? xleft : k; xfinish = (k == mmax) ? xright : (k+1); V(j,k) += (xfinish - xstart) * scalesecant; } } else if(floor(x1i) == floor(x0i)) { /* vertical */ #ifdef DEBUG Rprintf("vertical\n"); #endif k = clamp((int) floor(x1i), 0, Nx-1); if(y1i > y0i) { xlow = x0i; ylow = y0i; xhigh = x1i; yhigh = y1i; } else { xlow = x1i; ylow = y1i; xhigh = x0i; yhigh = y0i; } mmin = clamp((int) floor(ylow), 0, Ny-1); mmax = clamp((int) floor(yhigh), 0, Ny-1); invslope = (xhigh - xlow)/(yhigh - ylow); scalecosecant = wti * sqrt(pheight2 + invslope * invslope * pwidth2); #ifdef DEBUG Rprintf("i = %d\n", i); Rprintf("inverse slope = %lf\n", invslope); Rprintf("scaled cosecant = %lf\n", scalecosecant); #endif /* For this slope, one scaled y unit means 'pheight' original y units and invslope * pwidth original x units i.e. line length sqrt(pheight^2 + invslope^2 * pwidth^2) */ for(j = mmin; j <= mmax; j++) { ystart = (j == mmin)? ylow : j; yfinish = (j == mmax)? yhigh : (j+1); V(j,k) += (yfinish - ystart) * scalecosecant; } } else { /* general case */ #ifdef DEBUG Rprintf("general\n"); #endif if(x1i > x0i) { xleft = x0i; yleft = y0i; xright = x1i; yright = y1i; } else { xleft = x1i; yleft = y1i; xright = x0i; yright = y0i; } slope = (yright - yleft)/(xright - xleft); mleft = clamp((int) floor(xleft), 0, Nx-1); mright = clamp((int) floor(xright), 0, Nx-1); #ifdef DEBUG Rprintf("column range [%d, %d]\n", mleft, mright); #endif /* treat each vertical slice */ for(m = mleft; m <= mright; m++) { if(m == mleft) { xstart = xleft; ystart = yleft; } else { xstart = m; ystart = yleft + slope * (xstart - xleft); } if(m == mright) { xfinish = xright; yfinish = yright; } else { xfinish = m+1; yfinish = yleft + slope * (xfinish - xleft); } kstart = clamp((int) floor(ystart), 0, Ny-1); kfinish = clamp((int) floor(yfinish), 0, Ny-1); if(ystart < yfinish) { kmin = kstart; kmax = kfinish; ylow = ystart; yhigh = yfinish; } else { kmin = kfinish; kmax = kstart; ylow = yfinish; yhigh = ystart; } #ifdef DEBUG Rprintf("column %d: rows [%d, %d]\n", m, kmin, kmax); #endif for(k = kmin; k <= kmax; k++) { yyy0 = (k == kmin) ? ylow : k; yyy1 = (k == kmax) ? yhigh : (k+1); xxx0 = xstart + (yyy0 - ystart)/slope; xxx1 = xstart + (yyy1 - ystart)/slope; V(k, m) += wti * sqrt(pow(yyy1 - yyy0, 2) * pheight2 + pow(xxx1 - xxx0, 2) * pwidth2); } } } } } #ifdef DEBUG Rprintf("done.\n"); #endif } spatstat.geom/src/areadiff.c0000644000176200001440000001532614611065353015552 0ustar liggesusers/* areadiff.c Area difference function Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 $Revision: 1.16 $ $Date: 2022/10/20 06:36:12 $ A(x,r) = area of disc b(0,r) not covered by discs b(x_i,r) for x_i in x Area estimated by point-counting on a fine grid For use in area-interaction model and related calculations */ #undef DEBUG #include #include #include #include "chunkloop.h" #include "constants.h" /* Original version areadiff() 1 point u No trimming of discs */ void areadiff( /* inputs */ double *rad, /* radius */ double *x, double *y, /* coordinate vectors for point pattern */ int *nn, /* length of vectors x and y */ int *ngrid, /* dimensions of point-counting grid */ /* output */ double *answer /* computed area */ ) { double dx, dy, xg, yg, r, r2, a2, b2, xdif, ydif; int i, j, k, m, n, count, covered; r = *rad; r2 = r * r; n = *nn; m = *ngrid; dx = dy = 2 * r / (m-1); count = 0; /* run through grid points */ for(i = 0, xg = -r; i < m; i++, xg += dx) { a2 = r2 - xg *xg; for(j = 0, yg = -r; j < m; j++, yg += dy) { /* test for inside disc */ if(yg * yg < a2) { #ifdef DEBUG Rprintf("\n\n (xg,yg) = (%lf, %lf)\n", xg, yg); #endif /* run through data points seeking one close to (xy, yg) */ covered = 0; if(n > 0) { for(k = 0; k < n; k++) { #ifdef DEBUG Rprintf("(x[%d],y[%d]) = (%lf,%lf)\n", k, k, x[k], y[k]); #endif xdif = x[k] - xg; b2 = r2 - xdif * xdif; if(b2 > 0) { ydif = y[k] - yg; if(b2 - ydif * ydif > 0) { #ifdef DEBUG Rprintf("(x[%d], y[%d]) = (%lf, %lf) covers!\n", k, k, x[k], y[k]); #endif covered = 1; break; } } } } if(covered == 0) { ++count; #ifdef DEBUG Rprintf("Not covered; incrementing count\n"); #endif } } } } #ifdef DEBUG Rprintf("Count = %d\n", count); #endif /* calculate area */ *answer = ((double) count) * dx * dy; } /* similar function, handles multiple values of 'r' */ void areadifs( /* inputs */ double *rad, /* vector of radii */ int *nrads, /* length of 'rads' */ double *x, double *y, /* coordinate vectors for point pattern */ int *nxy, /* length of vectors x and y */ int *ngrid, /* dimensions of point-counting grid */ /* output */ double *answer /* computed areas (vector of length 'nrads') */ ) { double dx, dy, xg, yg, r, r2, a2, b2, xdif, ydif; int i, j, k, l, m, n, nr, m0, count, covered, maxchunk; n = *nxy; nr = *nrads; m = *ngrid; /* run through radii in chunks of 2^14 */ OUTERCHUNKLOOP(l, nr, maxchunk, 16384) { R_CheckUserInterrupt(); INNERCHUNKLOOP(l, nr, maxchunk, 16384) { r = rad[l]; if(r == 0.0) { answer[l] = 0.0; } else if(n == 0) { answer[l] = M_PI * r * r; } else { r2 = r * r; dx = dy = 2 * r / (m-1); count = 0; /* run through grid points in disc of radius r */ for(i = 0, xg = -r; i < m; i++, xg += dx) { a2 = r2 - xg * xg; m0 = (a2 > 0.0) ? floor(sqrt(a2)/dy) : 0; for(j = -m0, yg = -m0 * dy; j <= m0; j++, yg += dy) { #ifdef DEBUG Rprintf("\n\n (xg,yg) = (%lf, %lf)\n", xg, yg); #endif /* run through data points seeking one close to (xy, yg) */ covered = 0; for(k = 0; k < n; k++) { #ifdef DEBUG Rprintf("(x[%d],y[%d]) = (%lf,%lf)\n", k, k, x[k], y[k]); #endif xdif = x[k] - xg; b2 = r2 - xdif * xdif; if(b2 > 0) { ydif = y[k] - yg; if(b2 - ydif * ydif > 0) { #ifdef DEBUG Rprintf("(x[%d], y[%d]) = (%lf, %lf) covers!\n", k, k, x[k], y[k]); #endif covered = 1; break; } } } /* end of loop through data points */ if(covered == 0) { ++count; #ifdef DEBUG Rprintf("Not covered; incrementing count\n"); #endif } } } /* end of loop over grid points */ #ifdef DEBUG Rprintf("Count = %d\n", count); #endif /* calculate area for this value of r*/ answer[l] = ((double) count) * dx * dy; } /* end of if(r==0).. else {...} */ } } } /* Modified version multiple test points u discs constrained inside a rectangle */ void areaBdif( /* inputs */ double *rad, /* vector of radii */ int *nrads, /* length of 'rads' */ double *x, double *y, /* coordinate vectors for point pattern */ int *nxy, /* length of vectors x and y */ int *ngrid, /* dimensions of point-counting grid */ double *x0, double *y0, double *x1, double *y1, /* constraint rectangle */ /* output */ double *answer /* computed areas (vector of length 'nrads') */ ) { double dx, dy, xg, yg, r, r2, a, a2, b2, xdif, ydif; double xleft, xright, ylow, yhigh; double xmin, ymin, xmax, ymax; int i, j, k, l, m, n, nr, ileft, iright, mlow, mhigh, count, covered; n = *nxy; nr = *nrads; m = *ngrid; xmin = *x0; ymin = *y0; xmax = *x1; ymax = *y1; /* run through radii */ for(l = 0; l < nr; l++) { r = rad[l]; if(r == 0.0) { answer[l] = 0.0; } else if (n == 0) { answer[l]= M_PI * r * r; } else { r2 = r * r; dx = dy = 2 * r / (m-1); count = 0; /* run through grid points in disc intersected with box */ xleft = (xmin > -r) ? xmin : -r; xright = (xmax < r) ? xmax : r; ileft = ceil(xleft/dx); iright = floor(xright/dx); if(ileft <= iright) { for(i = ileft, xg = ileft * dx; i <= iright; i++, xg += dx) { a2 = r2 - xg * xg; a = (a2 > 0) ? sqrt(a2): 0.0; yhigh = (ymax < a) ? ymax: a; ylow = (ymin > -a) ? ymin: -a; mhigh = floor(yhigh/dy); mlow = ceil(ylow/dy); if(mlow <= mhigh) { for(j = mlow, yg = mlow * dy; j <= mhigh; j++, yg += dy) { #ifdef DEBUG Rprintf("\n\n (xg,yg) = (%lf, %lf)\n", xg, yg); #endif /* run through data points seeking one close to (xy, yg) */ covered = 0; for(k = 0; k < n; k++) { #ifdef DEBUG Rprintf("(x[%d],y[%d]) = (%lf,%lf)\n", k, k, x[k], y[k]); #endif xdif = x[k] - xg; b2 = r2 - xdif * xdif; if(b2 > 0) { ydif = y[k] - yg; if(b2 - ydif * ydif > 0) { #ifdef DEBUG Rprintf("(x[%d], y[%d]) = (%lf, %lf) covers!\n", k, k, x[k], y[k]); #endif covered = 1; break; } } } /* end of loop over data points */ if(covered == 0) { ++count; #ifdef DEBUG Rprintf("Not covered; incrementing count\n"); #endif } } } } } /* end of loop over grid points */ #ifdef DEBUG Rprintf("Count = %d\n", count); #endif /* calculate area for this value of r*/ answer[l] = ((double) count) * dx * dy; } /* end of if(r==0).. else {...} */ } /* end of loop over r values */ } spatstat.geom/src/xyseg.c0000644000176200001440000005240714611065353015151 0ustar liggesusers/* xyseg.c Computation with line segments xysegint compute intersections between line segments $Revision: 1.22 $ $Date: 2022/10/22 02:54:08 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #include #include #include #include #include #include "chunkloop.h" #define NIETS -1.0 #undef DEBUG #define INSIDE01(X,E) (X * (1.0 - X) >= -E) /* --------------- PAIRS OF PSP OBJECTS ---------------------- */ /* xysegint Determines intersections between each pair of line segments drawn from two lists of line segments. Line segments are given as x0, y0, dx, dy where (x0,y0) is the first endpoint and (dx, dy) is the vector from the first to the second endpoint. Points along a line segment are represented in parametric coordinates, (x,y) = (x0, y0) + t * (dx, dy). Output from xysegint() consists of five matrices xx, yy, ta, tb, ok. The (i,j)-th entries in these matrices give information about the intersection between the i-th segment in list 'a' and the j-th segment in list 'b'. The information is ok[i,j] = 1 if there is an intersection = 0 if not xx[i,j] = x coordinate of intersection yy[i,j] = y coordinate of intersection ta[i,j] = parameter of intersection point relative to i-th segment in list 'a' tb[i,j] = parameter of intersection point relative to j-th segment in list 'b' */ void xysegint( /* first segment pattern */ int *na, double *x0a, double *y0a, double *dxa, double *dya, /* second segment pattern */ int *nb, double *x0b, double *y0b, double *dxb, double *dyb, /* tolerance for determinant */ double *eps, /* output matrices */ double *xx, double *yy, double *ta, double *tb, int *ok ) { int i, j, ma, mb, ijpos, maxchunk; double determinant, absdet, diffx, diffy, tta, ttb, epsilon; ma = *na; mb = *nb; epsilon = *eps; OUTERCHUNKLOOP(j, mb, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, mb, maxchunk, 8196) { for(i = 0; i < ma; i++) { ijpos = j * ma + i; ok[ijpos] = 0; xx[ijpos] = yy[ijpos] = ta[ijpos] = tb[ijpos] = NIETS; determinant = dxb[j] * dya[i] - dyb[j] * dxa[i]; absdet = (determinant > 0) ? determinant : -determinant; #ifdef DEBUG Rprintf("i = %d, j = %d\n", i, j); Rprintf("segment A[i]: (%lf, %lf) to (%lf, %lf)\n", x0a[i], y0a[i], x0a[i] + dxa[i], y0a[i] + dya[i]); Rprintf("segment B[j]: (%lf, %lf) to (%lf, %lf)\n", x0b[j], y0b[j], x0b[j] + dxb[j], y0b[j] + dyb[j]); Rprintf("determinant=%lf\n", determinant); #endif if(absdet > epsilon) { diffx = (x0b[j] - x0a[i])/determinant; diffy = (y0b[j] - y0a[i])/determinant; ta[ijpos] = tta = - dyb[j] * diffx + dxb[j] * diffy; tb[ijpos] = ttb = - dya[i] * diffx + dxa[i] * diffy; #ifdef DEBUG Rprintf("ta = %lf, tb = %lf\n", tta, ttb); #endif if(INSIDE01(tta, epsilon) && INSIDE01(ttb, epsilon)) { /* intersection */ ok[ijpos] = 1; xx[ijpos] = x0a[i] + tta * dxa[i]; yy[ijpos] = y0a[i] + tta * dya[i]; #ifdef DEBUG Rprintf("segments intersect at (%lf, %lf)\n", xx[ijpos], yy[ijpos]); #endif } } } } } } /* Stripped-down version of xysegint that just returns logical matrix */ void xysi( /* first segment pattern */ int *na, double *x0a, double *y0a, double *dxa, double *dya, /* second segment pattern */ int *nb, double *x0b, double *y0b, double *dxb, double *dyb, /* tolerance for determinant */ double *eps, /* output matrix */ int *ok ) { int i, j, ma, mb, ijpos, maxchunk; double determinant, absdet, diffx, diffy, tta, ttb, epsilon; ma = *na; mb = *nb; epsilon = *eps; OUTERCHUNKLOOP(j, mb, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, mb, maxchunk, 8196) { for(i = 0; i < ma; i++) { ijpos = j * ma + i; ok[ijpos] = 0; determinant = dxb[j] * dya[i] - dyb[j] * dxa[i]; absdet = (determinant > 0) ? determinant : -determinant; if(absdet > epsilon) { diffx = (x0b[j] - x0a[i])/determinant; diffy = (y0b[j] - y0a[i])/determinant; tta = - dyb[j] * diffx + dxb[j] * diffy; ttb = - dya[i] * diffx + dxa[i] * diffy; if(INSIDE01(tta, epsilon) && INSIDE01(ttb, epsilon)) { /* intersection */ ok[ijpos] = 1; } } } } } } /* Test whether there is at least one intersection */ void xysiANY( /* first segment pattern */ int *na, double *x0a, double *y0a, double *dxa, double *dya, /* second segment pattern */ int *nb, double *x0b, double *y0b, double *dxb, double *dyb, /* tolerance for determinant */ double *eps, /* output (single logical value) */ int *ok ) { int i, j, ma, mb, maxchunk; double determinant, absdet, diffx, diffy, tta, ttb, epsilon; *ok = 0; ma = *na; mb = *nb; epsilon = *eps; OUTERCHUNKLOOP(j, mb, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, mb, maxchunk, 8196) { for(i = 0; i < ma; i++) { determinant = dxb[j] * dya[i] - dyb[j] * dxa[i]; absdet = (determinant > 0) ? determinant : -determinant; if(absdet > epsilon) { diffx = (x0b[j] - x0a[i])/determinant; diffy = (y0b[j] - y0a[i])/determinant; tta = - dyb[j] * diffx + dxb[j] * diffy; ttb = - dya[i] * diffx + dxa[i] * diffy; if(INSIDE01(tta, epsilon) && INSIDE01(ttb, epsilon)) { /* intersection */ *ok = 1; return; } } } } } } /* Analogue of xysegint when segments in list 'a' are infinite vertical lines */ void xysegVslice( /* first pattern (vertical lines) */ int *na, double *xa, /* second pattern (segments) */ int *nb, double *x0b, double *y0b, double *dxb, double *dyb, /* tolerance for determinant */ double *eps, /* outputs (matrices) */ double *yy, int *ok ) { int i, j, ma, mb, ijpos, maxchunk; double diffx0, diffx1, width, abswidth, epsilon; int notvertical; ma = *na; mb = *nb; epsilon = *eps; OUTERCHUNKLOOP(j, mb, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, mb, maxchunk, 8196) { /* determine whether segment j is nearly vertical */ width = dxb[j]; abswidth = (width > 0) ? width : -width; notvertical = (abswidth <= epsilon); for(i = 0; i < ma; i++) { ijpos = j * ma + i; ok[ijpos] = 0; yy[ijpos] = NIETS; /* test whether vertical line i separates endpoints of segment j */ diffx0 = xa[i] - x0b[j]; diffx1 = diffx0 - width; if(diffx0 * diffx1 <= 0) { /* intersection */ ok[ijpos] = 1; /* compute y-coordinate of intersection point */ if(notvertical) { yy[ijpos] = y0b[j] + diffx0 * dyb[j]/width; } else { /* vertical or nearly-vertical segment: pick midpoint */ yy[ijpos] = y0b[j] + dyb[j]/2.0; } } } } } } /* -------------- ONE PSP OBJECT ---------------------------- */ /* Similar to xysegint, but computes intersections between all pairs of segments in a single list, excluding the diagonal comparisons of course */ void xysegXint( /* segment pattern */ int *n, double *x0, double *y0, double *dx, double *dy, /* tolerance for determinant */ double *eps, /* outputs (matrices) */ double *xx, double *yy, double *ti, double *tj, int *ok ) { int i, j, m, mm1, ijpos, jipos, iipos, maxchunk; double determinant, absdet, diffx, diffy, tti, ttj, epsilon; m = *n; epsilon = *eps; mm1 = m - 1; OUTERCHUNKLOOP(j, mm1, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, mm1, maxchunk, 8196) { for(i = j+1; i < m; i++) { ijpos = j * m + i; jipos = i * m + j; ok[ijpos] = ok[jipos] = 0; xx[ijpos] = yy[ijpos] = ti[ijpos] = ti[jipos] = NIETS; xx[jipos] = yy[jipos] = tj[ijpos] = tj[jipos] = NIETS; determinant = dx[j] * dy[i] - dy[j] * dx[i]; absdet = (determinant > 0) ? determinant : -determinant; if(absdet > epsilon) { diffx = (x0[j] - x0[i])/determinant; diffy = (y0[j] - y0[i])/determinant; ti[ijpos] = tti = - dy[j] * diffx + dx[j] * diffy; tj[ijpos] = ttj = - dy[i] * diffx + dx[i] * diffy; tj[jipos] = ti[ijpos]; ti[jipos] = tj[ijpos]; if(INSIDE01(tti, epsilon) && INSIDE01(ttj, epsilon)) { ok[ijpos] = ok[jipos] = 1; xx[ijpos] = xx[jipos] = x0[i] + tti * dx[i]; yy[ijpos] = yy[jipos] = y0[i] + tti * dy[i]; } } } } } /* assign diagonal */ for(i = 0; i < m; i++) { iipos = i * m + i; ok[iipos] = 0; xx[iipos] = yy[iipos] = ti[iipos] = tj[iipos] = NIETS; } } /* Reduced version of xysegXint that returns logical matrix 'ok' only */ void xysxi( /* segment pattern */ int *n, double *x0, double *y0, double *dx, double *dy, /* tolerance for determinant */ double *eps, /* output (matrix) */ int *ok ) { int i, j, m, mm1, ijpos, jipos, iipos, maxchunk; double determinant, absdet, diffx, diffy, tti, ttj, epsilon; m = *n; epsilon = *eps; mm1 = m - 1; OUTERCHUNKLOOP(j, mm1, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, mm1, maxchunk, 8196) { for(i = j+1; i < m; i++) { ijpos = j * m + i; jipos = i * m + j; ok[ijpos] = ok[jipos] = 0; determinant = dx[j] * dy[i] - dy[j] * dx[i]; absdet = (determinant > 0) ? determinant : -determinant; if(absdet > epsilon) { diffx = (x0[j] - x0[i])/determinant; diffy = (y0[j] - y0[i])/determinant; tti = - dy[j] * diffx + dx[j] * diffy; ttj = - dy[i] * diffx + dx[i] * diffy; if(INSIDE01(tti, epsilon) && INSIDE01(ttj, epsilon)) { ok[ijpos] = ok[jipos] = 1; } } } } } /* assign diagonal */ for(i = 0; i < m; i++) { iipos = i * m + i; ok[iipos] = 0; } } /* ---------------------- ONE CLOSED POLYGON ------------------------ */ /* Identify self-intersections in a closed polygon (Similar to xysegXint, but does not compare segments which are cyclically adjacent in the list) */ void Cxypolyselfint( /* inputs (vectors of coordinates) */ int *n, double *x0, double *y0, double *dx, double *dy, /* input (tolerance for determinant) */ double *eps, /* outputs (matrices) */ double *xx, double *yy, double *ti, double *tj, int *ok ) { int i, j, k, m, m2, mm1, mm2, mstop, ijpos, jipos, maxchunk; double determinant, absdet, diffx, diffy, tti, ttj, epsilon; m = *n; epsilon = *eps; m2 = m * m; /* initialise matrices */ for(k = 0; k < m2; k++) { ok[k] = 0; xx[k] = yy[k] = ti[k] = tj[k] = NIETS; } if(m <= 2) return; /* Compare j with j+2, j+3, ...., m-1 Don't compare 0 with m-1 */ mm1 = m - 1; mm2 = m - 2; OUTERCHUNKLOOP(j, mm2, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, mm2, maxchunk, 8196) { mstop = (j > 0) ? m : mm1; for(i = j+2; i < mstop; i++) { ijpos = j * m + i; jipos = i * m + j; determinant = dx[j] * dy[i] - dy[j] * dx[i]; absdet = (determinant > 0) ? determinant : -determinant; if(absdet > epsilon) { diffx = (x0[j] - x0[i])/determinant; diffy = (y0[j] - y0[i])/determinant; ti[ijpos] = tti = - dy[j] * diffx + dx[j] * diffy; tj[ijpos] = ttj = - dy[i] * diffx + dx[i] * diffy; tj[jipos] = ti[ijpos]; ti[jipos] = tj[ijpos]; if(INSIDE01(tti, epsilon) && INSIDE01(ttj, epsilon)) { ok[ijpos] = ok[jipos] = 1; xx[ijpos] = xx[jipos] = x0[i] + tti * dx[i]; yy[ijpos] = yy[jipos] = y0[i] + tti * dy[i]; } } } } } } /* Just determines whether there is self-intersection (exits quicker & uses less space) */ void xypsi( /* segment pattern */ int *n, double *x0, double *y0, double *dx, double *dy, /* inputs (distances beyond which intersection is impossible) */ double *xsep, double *ysep, /* input (tolerance for determinant) */ double *eps, /* input (flag) */ int *proper, /* output */ int *answer ) { int i, j, m, mm1, mm2, mstop, prop, maxchunk; double determinant, absdet, diffx, diffy, tti, ttj, epsilon; double Xsep, Ysep; m = *n; prop = *proper; Xsep = *xsep; Ysep = *ysep; epsilon = *eps; *answer = 0; if(m <= 2) return; /* Compare j with j+2, j+3, ...., m-1 Don't compare 0 with m-1 */ mm1 = m - 1; mm2 = m - 2; OUTERCHUNKLOOP(j, mm2, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, mm2, maxchunk, 8196) { mstop = (j > 0) ? m : mm1; for(i = j+2; i < mstop; i++) { diffx = x0[j] - x0[i]; diffy = y0[j] - y0[i]; if(diffx < Xsep && diffx > -Xsep && diffy < Ysep && diffy > -Ysep) { determinant = dx[j] * dy[i] - dy[j] * dx[i]; absdet = (determinant > 0) ? determinant : -determinant; if(absdet > epsilon) { diffx = diffx/determinant; diffy = diffy/determinant; tti = - dy[j] * diffx + dx[j] * diffy; ttj = - dy[i] * diffx + dx[i] * diffy; if(INSIDE01(tti, epsilon) && INSIDE01(ttj, epsilon)) { /* intersection occurs */ if(prop == 0 || (tti != 0.0 && tti != 1.0) || (ttj != 0.0 && ttj != 1.0)) { /* proper intersection */ *answer = 1; return; } } } } } } } } /* ---------------- .Call INTERFACE --------------------------- Analogues of functions above, but using the .Call interface and dynamic storage allocation, to save space. */ SEXP Cxysegint(SEXP x0a, SEXP y0a, SEXP dxa, SEXP dya, SEXP x0b, SEXP y0b, SEXP dxb, SEXP dyb, SEXP eps) { int i, j, k, na, nb; double determinant, absdet, diffx, diffy, tta, ttb; int nout, noutmax, newmax, maxchunk; double epsilon; double *x0A, *y0A, *dxA, *dyA, *x0B, *y0B, *dxB, *dyB; double *ta, *tb, *x, *y; int *ia, *jb; SEXP out, iAout, jBout, tAout, tBout, xout, yout; double *tAoutP, *tBoutP, *xoutP, *youtP; int *iAoutP, *jBoutP; PROTECT(x0a = AS_NUMERIC(x0a)); PROTECT(y0a = AS_NUMERIC(y0a)); PROTECT(dxa = AS_NUMERIC(dxa)); PROTECT(dya = AS_NUMERIC(dya)); PROTECT(x0b = AS_NUMERIC(x0b)); PROTECT(y0b = AS_NUMERIC(y0b)); PROTECT(dxb = AS_NUMERIC(dxb)); PROTECT(dyb = AS_NUMERIC(dyb)); PROTECT(eps = AS_NUMERIC(eps)); /* that's 9 protected */ /* get pointers */ x0A = NUMERIC_POINTER(x0a); y0A = NUMERIC_POINTER(y0a); dxA = NUMERIC_POINTER(dxa); dyA = NUMERIC_POINTER(dya); x0B = NUMERIC_POINTER(x0b); y0B = NUMERIC_POINTER(y0b); dxB = NUMERIC_POINTER(dxb); dyB = NUMERIC_POINTER(dyb); /* determine length of vectors */ na = LENGTH(x0a); nb = LENGTH(x0b); epsilon = *(NUMERIC_POINTER(eps)); /* guess amount of storage required for output */ noutmax = (na > nb) ? na : nb; nout = 0; ia = (int *) R_alloc(noutmax, sizeof(int)); jb = (int *) R_alloc(noutmax, sizeof(int)); ta = (double *) R_alloc(noutmax, sizeof(double)); tb = (double *) R_alloc(noutmax, sizeof(double)); x = (double *) R_alloc(noutmax, sizeof(double)); y = (double *) R_alloc(noutmax, sizeof(double)); /* scan data and collect intersections */ OUTERCHUNKLOOP(j, nb, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, nb, maxchunk, 8196) { for(i = 0; i < na; i++) { determinant = dxB[j] * dyA[i] - dyB[j] * dxA[i]; absdet = (determinant > 0) ? determinant : -determinant; #ifdef DEBUG Rprintf("i = %d, j = %d\n", i, j); Rprintf("segment A[i]: (%lf, %lf) to (%lf, %lf)\n", x0A[i], y0A[i], x0A[i] + dxA[i], y0A[i] + dyA[i]); Rprintf("segment B[j]: (%lf, %lf) to (%lf, %lf)\n", x0B[j], y0B[j], x0B[j] + dxB[j], y0B[j] + dyB[j]); Rprintf("determinant=%lf\n", determinant); #endif if(absdet > epsilon) { diffx = (x0B[j] - x0A[i])/determinant; diffy = (y0B[j] - y0A[i])/determinant; tta = - dyB[j] * diffx + dxB[j] * diffy; ttb = - dyA[i] * diffx + dxA[i] * diffy; #ifdef DEBUG Rprintf("ta = %lf, tb = %lf\n", tta, ttb); #endif if(INSIDE01(tta, epsilon) && INSIDE01(ttb, epsilon)) { /* intersection */ if(nout >= noutmax) { /* storage overflow - increase space */ newmax = 4 * noutmax; ia = (int *) S_realloc((char *) ia, newmax, noutmax, sizeof(int)); jb = (int *) S_realloc((char *) jb, newmax, noutmax, sizeof(int)); ta = (double *) S_realloc((char *) ta, newmax, noutmax, sizeof(double)); tb = (double *) S_realloc((char *) tb, newmax, noutmax, sizeof(double)); x = (double *) S_realloc((char *) x, newmax, noutmax, sizeof(double)); y = (double *) S_realloc((char *) y, newmax, noutmax, sizeof(double)); noutmax = newmax; } ta[nout] = tta; tb[nout] = ttb; ia[nout] = i; jb[nout] = j; x[nout] = x0A[i] + tta * dxA[i]; y[nout] = y0A[i] + tta * dyA[i]; #ifdef DEBUG Rprintf("segments intersect at (%lf, %lf)\n", x[nout], y[nout]); #endif ++nout; } } } } } /* pack up */ PROTECT(iAout = NEW_INTEGER(nout)); PROTECT(jBout = NEW_INTEGER(nout)); PROTECT(tAout = NEW_NUMERIC(nout)); PROTECT(tBout = NEW_NUMERIC(nout)); PROTECT(xout = NEW_NUMERIC(nout)); PROTECT(yout = NEW_NUMERIC(nout)); /* 9 + 6 = 15 protected */ iAoutP = INTEGER_POINTER(iAout); jBoutP = INTEGER_POINTER(jBout); tAoutP = NUMERIC_POINTER(tAout); tBoutP = NUMERIC_POINTER(tBout); xoutP = NUMERIC_POINTER(xout); youtP = NUMERIC_POINTER(yout); for(k = 0; k < nout; k++) { iAoutP[k] = ia[k]; jBoutP[k] = jb[k]; tAoutP[k] = ta[k]; tBoutP[k] = tb[k]; xoutP[k] = x[k]; youtP[k] = y[k]; } PROTECT(out = NEW_LIST(6)); /* 15 + 1 = 16 protected */ SET_VECTOR_ELT(out, 0, iAout); SET_VECTOR_ELT(out, 1, jBout); SET_VECTOR_ELT(out, 2, tAout); SET_VECTOR_ELT(out, 3, tBout); SET_VECTOR_ELT(out, 4, xout); SET_VECTOR_ELT(out, 5, yout); UNPROTECT(16); return(out); } /* Similar to Cxysegint, but computes intersections between all pairs of segments in a single list, excluding the diagonal comparisons of course */ SEXP CxysegXint(SEXP x0, SEXP y0, SEXP dx, SEXP dy, SEXP eps) { int i, j, k, n, n1; double determinant, absdet, diffx, diffy, tti, ttj; int nout, noutmax, newmax, maxchunk; double epsilon; double *X0, *Y0, *Dx, *Dy; double *ti, *tj, *x, *y; int *ii, *jj; SEXP out, iout, jout, tiout, tjout, xout, yout; double *tioutP, *tjoutP, *xoutP, *youtP; int *ioutP, *joutP; PROTECT(x0 = AS_NUMERIC(x0)); PROTECT(y0 = AS_NUMERIC(y0)); PROTECT(dx = AS_NUMERIC(dx)); PROTECT(dy = AS_NUMERIC(dy)); PROTECT(eps = AS_NUMERIC(eps)); /* that's 5 protected */ /* get pointers */ X0 = NUMERIC_POINTER(x0); Y0 = NUMERIC_POINTER(y0); Dx = NUMERIC_POINTER(dx); Dy = NUMERIC_POINTER(dy); /* determine length of vectors */ n = LENGTH(x0); epsilon = *(NUMERIC_POINTER(eps)); /* guess amount of storage required for output */ noutmax = n; nout = 0; ii = (int *) R_alloc(noutmax, sizeof(int)); jj = (int *) R_alloc(noutmax, sizeof(int)); ti = (double *) R_alloc(noutmax, sizeof(double)); tj = (double *) R_alloc(noutmax, sizeof(double)); x = (double *) R_alloc(noutmax, sizeof(double)); y = (double *) R_alloc(noutmax, sizeof(double)); /* scan data */ n1 = n - 1; OUTERCHUNKLOOP(j, n1, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, n1, maxchunk, 8196) { for(i = j+1; i < n; i++) { determinant = Dx[j] * Dy[i] - Dy[j] * Dx[i]; absdet = (determinant > 0) ? determinant : -determinant; if(absdet > epsilon) { diffx = (X0[j] - X0[i])/determinant; diffy = (Y0[j] - Y0[i])/determinant; tti = - Dy[j] * diffx + Dx[j] * diffy; ttj = - Dy[i] * diffx + Dx[i] * diffy; if(INSIDE01(tti,epsilon) && INSIDE01(ttj,epsilon)) { /* intersection */ if(nout >= noutmax) { /* storage overflow - increase space */ newmax = 4 * noutmax; ii = (int *) S_realloc((char *) ii, newmax, noutmax, sizeof(int)); jj = (int *) S_realloc((char *) jj, newmax, noutmax, sizeof(int)); ti = (double *) S_realloc((char *) ti, newmax, noutmax, sizeof(double)); tj = (double *) S_realloc((char *) tj, newmax, noutmax, sizeof(double)); x = (double *) S_realloc((char *) x, newmax, noutmax, sizeof(double)); y = (double *) S_realloc((char *) y, newmax, noutmax, sizeof(double)); noutmax = newmax; } ti[nout] = tti; tj[nout] = ttj; ii[nout] = i; jj[nout] = j; x[nout] = X0[i] + tti * Dx[i]; y[nout] = Y0[i] + tti * Dy[i]; ++nout; } } } } } /* pack up */ PROTECT(iout = NEW_INTEGER(nout)); PROTECT(jout = NEW_INTEGER(nout)); PROTECT(tiout = NEW_NUMERIC(nout)); PROTECT(tjout = NEW_NUMERIC(nout)); PROTECT(xout = NEW_NUMERIC(nout)); PROTECT(yout = NEW_NUMERIC(nout)); /* 5 + 6 = 11 protected */ ioutP = INTEGER_POINTER(iout); joutP = INTEGER_POINTER(jout); tioutP = NUMERIC_POINTER(tiout); tjoutP = NUMERIC_POINTER(tjout); xoutP = NUMERIC_POINTER(xout); youtP = NUMERIC_POINTER(yout); for(k = 0; k < nout; k++) { ioutP[k] = ii[k]; joutP[k] = jj[k]; tioutP[k] = ti[k]; tjoutP[k] = tj[k]; xoutP[k] = x[k]; youtP[k] = y[k]; } PROTECT(out = NEW_LIST(6)); /* 11 + 1 = 12 protected */ SET_VECTOR_ELT(out, 0, iout); SET_VECTOR_ELT(out, 1, jout); SET_VECTOR_ELT(out, 2, tiout); SET_VECTOR_ELT(out, 3, tjout); SET_VECTOR_ELT(out, 4, xout); SET_VECTOR_ELT(out, 5, yout); UNPROTECT(12); return(out); } spatstat.geom/src/loccumx.h0000644000176200001440000000401014611065353015454 0ustar liggesusers/* loccumx.h C template for loccum.c grid-to-data or data-cross-data functions $Revision: 1.7 $ $Date: 2022/10/21 10:43:01 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 macros: FNAME function name NULVAL initial value (empty sum = 0, empty product = 1) INC(A,B) increment operation A += B or A *= B */ void FNAME( /* inputs */ int *ntest, double *xtest, double *ytest, int *ndata, double *xdata, double *ydata, double *vdata, int *nr, double *rmax, /* output */ double *ans /* matrix of column vectors of functions for each point of first pattern */ ) { int Ntest, Ndata, Nr, Nans; double Rmax; int i, j, k, jleft, kmin, maxchunk, columnstart; double Rmax2, rstep, xtesti, ytesti, xleft; double dx, dy, dx2, d2, d, contrib; Ntest = *ntest; Ndata = *ndata; Nr = *nr; Rmax = *rmax; if(Ntest == 0) return; Nans = Nr * Ntest; /* initialise products to 1 */ OUTERCHUNKLOOP(k, Nans, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(k, Nans, maxchunk, 8196) { ans[k] = NULVAL; } } if(Ndata == 0) return; rstep = Rmax/(Nr-1); Rmax2 = Rmax * Rmax; jleft = 0; OUTERCHUNKLOOP(i, Ntest, maxchunk, 8196) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, Ntest, maxchunk, 8196) { xtesti = xtest[i]; ytesti = ytest[i]; columnstart = Nr * i; /* start position for f_i(.) in 'ans' */ /* adjust starting point */ xleft = xtesti - Rmax; while((xdata[jleft] < xleft) && (jleft+1 < Ndata)) ++jleft; /* process from jleft until |dx| > Rmax */ for(j=jleft; j < Ndata; j++) { dx = xdata[j] - xtesti; dx2 = dx * dx; if(dx2 > Rmax2) break; dy = ydata[j] - ytesti; d2 = dx2 + dy * dy; if(d2 <= Rmax2) { d = sqrt(d2); kmin = (int) ceil(d/rstep); if(kmin < Nr) { contrib = vdata[j]; for(k = kmin; k < Nr; k++) INC(ans[columnstart + k] , contrib); } } } } } } spatstat.geom/src/nndist.h0000644000176200001440000000366514611065353015320 0ustar liggesusers/* nndist.h Code template for C functions supporting nndist and nnwhich (k=1) THE FOLLOWING CODE ASSUMES THAT y IS SORTED IN ASCENDING ORDER This code is #included multiple times in nndistance.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour Either or both DIST and WHICH may be defined. Copyright (C) Adrian Baddeley, Jens Oehlschlagel and Rolf Turner 2000-2012 Licence: GPL >= 2 $Revision: 1.3 $ $Date: 2022/10/21 10:43:01 $ */ void FNAME( int *n, double *x, double *y, #ifdef DIST double *nnd, #endif #ifdef WHICH int *nnwhich, #endif double *huge ) { int npoints, i, maxchunk, left, right; double d2, d2min, xi, yi, dx, dy, dy2, hu, hu2; #ifdef WHICH int which; #endif hu = *huge; hu2 = hu * hu; npoints = *n; /* loop in chunks of 2^16 */ i = 0; maxchunk = 0; while(i < npoints) { R_CheckUserInterrupt(); maxchunk += 65536; if(maxchunk > npoints) maxchunk = npoints; for(; i < maxchunk; i++) { d2min = hu2; #ifdef WHICH which = -1; #endif xi = x[i]; yi = y[i]; if(i < npoints - 1) { /* search forward */ for(right = i + 1; right < npoints; ++right) { dy = y[right] - yi; dy2 = dy * dy; if(dy2 > d2min) break; dx = x[right] - xi; d2 = dx * dx + dy2; if (d2 < d2min) { d2min = d2; #ifdef WHICH which = right; #endif } } } if(i > 0){ /* search backward */ for(left = i - 1; left >= 0; --left) { dy = yi - y[left]; dy2 = dy * dy; if(dy2 > d2min) break; dx = x[left] - xi; d2 = dx * dx + dy2; if (d2 < d2min) { d2min = d2; #ifdef WHICH which = left; #endif } } } #ifdef DIST nnd[i] = sqrt(d2min); #endif #ifdef WHICH nnwhich[i] = which + 1; /* R indexing */ #endif } } } spatstat.geom/src/discarea.c0000644000176200001440000001524014611065353015557 0ustar liggesusers/* disc.c Area of intersection between disc and polygonal window $Revision: 1.8 $ $Date: 2022/10/20 10:57:43 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef DEBUG #include #include #define MIN(A,B) (((A) < (B)) ? (A) : (B)) #define MAX(A,B) (((A) > (B)) ? (A) : (B)) #ifndef PI #define PI 3.1415926535898 #endif double DiscContrib(double xleft, double yleft, double xright, double yright, double eps); /* defined below */ void discareapoly( /* inputs */ int *nc, double *xc, double *yc, int *nr, double *rmat, int *nseg, double *x0, double *y0, double *x1, double *y1, double *eps, /* output */ double *out ) { int n, m, i, j, k, nradperpt; double radius, radius2, total, contrib; double xx0, xx1, yy0, yy1, xleft, xright, yleft, yright, xcentre, ycentre; double epsilon; n = *nc; nradperpt = *nr; m = *nseg; epsilon = *eps; for(i = 0; i < n; i++) { xcentre = xc[i]; ycentre = yc[i]; #ifdef DEBUG Rprintf("\ni = %d:\n centre = (%lf, %lf)\n", i, xcentre, ycentre); #endif for(j = 0; j < nradperpt; j++) { radius = rmat[ j * n + i]; radius2 = radius * radius; #ifdef DEBUG Rprintf("radius = %lf\n", radius); #endif total = 0.0; for(k=0; k < m; k++) { #ifdef DEBUG Rprintf("k = %d\n", k); #endif xx0 = x0[k]; yy0 = y0[k]; xx1 = x1[k]; yy1 = y1[k]; #ifdef DEBUG Rprintf("(%lf,%lf) to (%lf,%lf)\n", xx0, yy0, xx1, yy1); #endif /* refer to unit disc at origin */ /* arrange so that xleft < xright */ if(radius <= epsilon) contrib = 0.0; else if(xx0 < xx1) { xleft = (xx0 - xcentre)/radius; xright = (xx1 - xcentre)/radius; yleft = (yy0 - ycentre)/radius; yright = (yy1 - ycentre)/radius; contrib = - radius2 * DiscContrib(xleft,yleft,xright,yright,epsilon); } else { xleft = (xx1 - xcentre)/radius; xright = (xx0 - xcentre)/radius; yleft = (yy1 - ycentre)/radius; yright = (yy0 - ycentre)/radius; contrib = radius2 * DiscContrib(xleft,yleft,xright,yright,epsilon); } #ifdef DEBUG Rprintf("contrib = %lf\n contrib/(pi * r^2)=%lf\n", contrib, contrib/(PI * radius2)); #endif total += contrib; } out[ j * n + i] = total; #ifdef DEBUG Rprintf("total = %lf\ntotal/(pi * r^2) = %lf\n", total, total/(PI * radius2)); #endif } } } /* area of intersection of unit disc with halfplane x <= v */ #ifdef DEBUG #define TRIGBIT(V) trigbit(V) double trigbit(double v) { double zero, result; zero = 0.0; if(v < -1.0) return(zero); if(v > 1.0) return(PI); result = PI/2 + asin(v) + v * sqrt(1 - v * v); Rprintf("trigbit: v = %lf, asin(v)=%lf, result=%lf\n", v, asin(v), result); return(result); } #else #define TRIGBIT(V) (((V) <= -1.0) ? 0.0 : (((V) >= 1.0) ? PI : \ (PI/2 + asin(V) + (V) * sqrt(1 - (V) * (V))))) #endif /* Find the area of intersection between a disc centre = (0,0), radius = 1 and the trapezium with upper segment (xleft, yleft) to (xright, yright) ASSUMES xleft < xright */ double DiscContrib(double xleft, double yleft, double xright, double yright, double eps) /* NOTE: unit disc centred at origin */ { double xlo, xhi, zero, slope, intercept, A, B, C, det; double xcut1, xcut2, ycut1, ycut2, xunder1, xunder2, dx, dx2, result; #ifdef DEBUG double increm; Rprintf( "DiscContrib: xleft=%lf, yleft=%lf, xright=%lf, yright=%lf\n", xleft, yleft, xright, yright); #endif zero = 0.0; /* determine relevant range of x coordinates */ xlo = MAX(xleft, (-1.0)); xhi = MIN(xright, 1.0); if(xlo >= xhi - eps) { /* intersection is empty or negligible */ #ifdef DEBUG Rprintf("intersection is empty or negligible\n"); #endif return(zero); } /* find intersection points between the circle and the line containing upper segment */ slope = (yright - yleft)/(xright - xleft); intercept = yleft - slope * xleft; A = 1 + slope * slope; B = 2 * slope * intercept; C = intercept * intercept - 1.0; det = B * B - 4 * A * C; #ifdef DEBUG Rprintf("slope=%lf, intercept=%lf\nA = %lf, B=%lf, C=%lf, det=%lf\n", slope, intercept, A, B, C, det); #endif if(det <= 0.0) { /* no crossing between disc and infinite line */ if(intercept < 0.0) /* segment is below disc; intersection is empty */ return(zero); /* segment is above disc */ result = TRIGBIT(xhi) - TRIGBIT(xlo); return(result); } xcut1 = (- B - sqrt(det))/(2 * A); xcut2 = (- B + sqrt(det))/(2 * A); /* partition [xlo, xhi] into pieces delimited by {xcut1, xcut2} */ if(xcut1 >= xhi || xcut2 <= xlo) { /* segment is outside disc */ if(yleft < 0.0) { #ifdef DEBUG Rprintf("segment is beneath disc\n"); #endif result = zero; } else { #ifdef DEBUG Rprintf("segment is above disc\n"); #endif result = TRIGBIT(xhi) - TRIGBIT(xlo); } return(result); } /* possibly three parts */ #ifdef DEBUG Rprintf("up to three pieces\n"); #endif result = zero; ycut1 = intercept + slope * xcut1; ycut2 = intercept + slope * xcut2; if(xcut1 > xlo) { /* part to left of cut */ #ifdef DEBUG Rprintf("left of cut: [%lf, %lf]\n", xlo, xcut1); if(ycut1 < 0.0) Rprintf("below disc - no intersection\n"); else { increm = TRIGBIT(xcut1) - TRIGBIT(xlo); Rprintf("increment = %lf\n", increm); result += increm; } #else if(ycut1 >= 0.0) result += TRIGBIT(xcut1) - TRIGBIT(xlo); #endif } if(xcut2 < xhi) { /* part to right of cut */ #ifdef DEBUG Rprintf("right of cut: [%lf, %lf]\n", xcut2, xhi); if(ycut2 < 0.0) Rprintf("below disc - no intersection\n"); else { increm = TRIGBIT(xhi) - TRIGBIT(xcut2); Rprintf("increment = %lf\n", increm); result += increm; } #else if(ycut2 >= 0.0) result += TRIGBIT(xhi) - TRIGBIT(xcut2); #endif } /* part underneath cut */ xunder1 = MAX(xlo, xcut1); xunder2 = MIN(xhi, xcut2); dx = xunder2 - xunder1; dx2 = xunder2 * xunder2 - xunder1 * xunder1; #ifdef DEBUG Rprintf("underneath cut: [%lf, %lf]\n", xunder1, xunder2); increm = intercept * dx + slope * dx2/2 + (TRIGBIT(xunder2) - TRIGBIT(xunder1))/2; Rprintf("increment = %lf\n", increm); result += increm; #else result += intercept * dx + slope * dx2/2 + (TRIGBIT(xunder2) - TRIGBIT(xunder1))/2; #endif return(result); } #ifdef DEBUG /* interface to low level function, for debugging only */ void RDCtest(double *xleft, double *yleft, double *xright, double *yright, double *eps, double *value) { *value = DiscContrib(*xleft, *yleft, *xright, *yright, *eps); } #endif spatstat.geom/src/knngrid.h0000644000176200001440000001265514611065353015454 0ustar liggesusers #if (1 == 0) /* knngrid.h Code template for C functions k-nearest neighbours (k > 1) of each grid point THE FOLLOWING CODE ASSUMES THAT POINT PATTERN (xp, yp) IS SORTED IN ASCENDING ORDER OF x COORDINATE This code is #included multiple times in knngrid.c Variables used: FNAME function name DIST #defined if function returns distance to nearest neighbour WHICH #defined if function returns id of nearest neighbour Either or both DIST and WHICH may be defined. Copyright (C) Adrian Baddeley, Jens Oehlschlagel and Rolf Turner 2000-2013 Licence: GPL >= 2 $Revision: 1.7 $ $Date: 2022/10/22 09:16:41 $ */ #endif #undef PRINTALOT void FNAME( /* pixel grid dimensions */ int *nx, double *x0, double *xstep, int *ny, double *y0, double *ystep, /* data points */ int *np, double *xp, double *yp, /* maximum order of neighbours */ int *kmax, /* outputs */ double *nnd, int *nnwhich, /* prior upper bound on pairwise distances */ double *huge ) { int Nxcol, Nyrow; int i, j, ijpos; int Npoints, Nk, Nk1; int mleft, mright, mwhich, lastmwhich, unsorted, k, k1; double X0, Y0, Xstep, Ystep; double d2, d2minK, xj, yi, dx, dy, dx2, hu, hu2, tmp; double *d2min; #ifdef WHICH int *which; int itmp; #endif Nxcol = *nx; Nyrow = *ny; Npoints = *np; Nk = *kmax; hu = *huge; X0 = *x0; Y0 = *y0; Xstep = *xstep; Ystep = *ystep; Nk1 = Nk - 1; hu2 = hu * hu; if(Npoints == 0) return; lastmwhich = mwhich = 0; /* create space to store the nearest neighbour distances and indices for the current grid point */ d2min = (double *) R_alloc((size_t) Nk, sizeof(double)); #ifdef WHICH which = (int *) R_alloc((size_t) Nk, sizeof(int)); #endif /* loop over pixels */ for(j = 0, xj = X0; j < Nxcol; j++, xj += Xstep) { R_CheckUserInterrupt(); #ifdef PRINTALOT Rprintf("j=%d, xj=%lf\n", j, xj); #endif for(i = 0, yi = Y0; i < Nyrow; i++, yi += Ystep) { #ifdef PRINTALOT Rprintf("\ti=%d, yi = %lf\n", i, yi); #endif /* initialise nn distances and indices */ d2minK = hu2; for(k = 0; k < Nk; k++) { d2min[k] = hu2; #ifdef WHICH which[k] = -1; #endif } if(lastmwhich < Npoints) { /* search forward from previous nearest neighbour */ for(mright = lastmwhich; mright < Npoints; ++mright) { dx = xp[mright] - xj; dx2 = dx * dx; #ifdef PRINTALOT Rprintf("\t\t%d\n", mright); #endif if(dx2 > d2minK) /* note that dx2 >= d2minK could break too early */ break; dy = yp[mright] - yi; d2 = dy * dy + dx2; if (d2 < d2minK) { #ifdef PRINTALOT Rprintf("\t\t\tNeighbour: d2=%lf\n", d2); #endif /* overwrite last entry in list of neighbours */ d2min[Nk1] = d2; mwhich = mright; #ifdef WHICH which[Nk1] = mright; #endif /* bubble sort */ unsorted = YES; for(k = Nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } /* adjust maximum distance */ d2minK = d2min[Nk1]; #ifdef PRINTALOT Rprintf("\t\t\tUpdated d2minK=%lf\n", d2minK); for(k = 0; k < Nk; k++) Rprintf("\t\t\t\td2min[%d]=%lf\n", k, d2min[k]); #ifdef WHICH for(k = 0; k < Nk; k++) Rprintf("\t\t\t\twhich[%d]=%d\n", k, which[k]); #endif #endif } } /* end forward search */ } if(lastmwhich > 0) { /* search backward from previous nearest neighbour */ for(mleft = lastmwhich - 1; mleft >= 0; --mleft) { dx = xj - xp[mleft]; dx2 = dx * dx; #ifdef PRINTALOT Rprintf("\t\t%d\n", mleft); #endif if(dx2 > d2minK) /* note that dx2 >= d2minK could break too early */ break; dy = yp[mleft] - yi; d2 = dy * dy + dx2; if (d2 < d2minK) { #ifdef PRINTALOT Rprintf("\t\t\tNeighbour: d2=%lf\n", d2); #endif /* overwrite last entry in list of neighbours */ mwhich = mleft; d2min[Nk1] = d2; #ifdef WHICH which[Nk1] = mleft; #endif /* bubble sort */ unsorted = YES; for(k = Nk1; unsorted && k > 0; k--) { k1 = k - 1; if(d2min[k] < d2min[k1]) { /* swap entries */ tmp = d2min[k1]; d2min[k1] = d2min[k]; d2min[k] = tmp; #ifdef WHICH itmp = which[k1]; which[k1] = which[k]; which[k] = itmp; #endif } else { unsorted = NO; } } /* adjust maximum distance */ d2minK = d2min[Nk1]; #ifdef PRINTALOT Rprintf("\t\t\tUpdated d2minK=%lf\n", d2minK); for(k = 0; k < Nk; k++) Rprintf("\t\t\t\td2min[%d]=%lf\n", k, d2min[k]); #ifdef WHICH for(k = 0; k < Nk; k++) Rprintf("\t\t\t\twhich[%d]=%d\n", k, which[k]); #endif #endif } } /* end backward search */ } /* remember index of most recently-encountered neighbour */ lastmwhich = mwhich; #ifdef PRINTALOT Rprintf("\t\tlastmwhich=%d\n", lastmwhich); #endif /* copy nn distances for grid point (i, j) to output array nnd[ , i, j] */ ijpos = Nk * (i + j * Nyrow); for(k = 0; k < Nk; k++) { #ifdef DIST nnd[ijpos + k] = sqrt(d2min[k]); #endif #ifdef WHICH nnwhich[ijpos + k] = which[k] + 1; /* R indexing */ #endif } /* end of loop over points i */ } } } spatstat.geom/NAMESPACE0000644000176200001440000013402214765743246014306 0ustar liggesusers## spatstat.geom NAMESPACE file ## ................ Import packages .................. import(stats,graphics,grDevices,utils,methods) import(spatstat.utils,spatstat.data,spatstat.univar) import(polyclip) importFrom(deldir, deldir,duplicatedxy,tile.list) ## ................ Load dynamic library .............. ## (native routines are registered in init.c) ## (entry points are symbols with prefix "SG_") useDynLib(spatstat.geom, .registration=TRUE, .fixes="SG_") ## ////////// DO NOT EDIT THE FOLLOWING /////////////// ## //////// it is generated automatically ///////////// # .................................................. # Automatically-generated list of documented objects # .................................................. export("$.hyperframe") export("$<-.hyperframe") export("acedist.noshow") export("acedist.show") export("add.texture") export("affine") export("affine.diagramobj") export("affine.distfun") export("affine.im") export("affine.layered") export("affine.owin") export("affine.ppp") export("affine.psp") export("affine.tess") export("affinexy") export("affinexypolygon") export("allElementsIdentical") export("angles.psp") export("anycrossing.psp") export("anyDuplicated.ppp") export("anyDuplicated.ppx") export("anylapply") export("[.anylist") export("[<-.anylist") export("anylist") export("anyNA.im") export("append.psp") export("applynbd") export("applyPolyclipArgs") export("applytolayers") export("area") export("area.default") export("areaGain") export("areaGain.diri") export("areaGain.grid") export("areaLoss") export("areaLoss.diri") export("areaLoss.grid") export("areaLoss.poly") export("area.owin") export("as.anylist") export("as.array.im") export("as.box3") export("as.boxx") export("as.character.unitname") export("as.colourmap") export("as.colourmap.colourmap") export("as.colourmap.symbolmap") export("as.data.frame.hyperframe") export("as.data.frame.im") export("as.data.frame.owin") export("as.data.frame.ppp") export("as.data.frame.ppplist") export("as.data.frame.ppx") export("as.data.frame.psp") export("as.data.frame.tess") export("as.double.im") export("as.function.im") export("as.function.owin") export("as.function.tess") export("as.hyperframe") export("as.hyperframe.anylist") export("as.hyperframe.data.frame") export("as.hyperframe.default") export("as.hyperframe.hyperframe") export("as.hyperframe.listof") export("as.hyperframe.ppx") export("as.im") export("as.im.data.frame") export("as.im.default") export("as.im.distfun") export("as.im.expression") export("as.im.function") export("as.im.funxy") export("as.im.im") export("as.imlist") export("as.im.matrix") export("as.im.nnfun") export("as.im.owin") export("as.im.ppp") export("as.im.tess") export("as.layered") export("as.layered.default") export("as.layered.listof") export("as.layered.ppp") export("as.layered.solist") export("as.layered.splitppp") export("as.linimlist") export("as.list.hyperframe") export("as.listof") export("as.mask") export("AsMaskInternal") export("as.mask.psp") export("as.matrix.im") export("as.matrix.owin") export("as.matrix.ppx") export("as.owin") export("as.owin.boxx") export("as.owin.data.frame") export("as.owin.default") export("as.owin.distfun") export("as.owin.funxy") export("as.owin.im") export("as.owin.layered") export("as.owin.nnfun") export("as.owin.owin") export("as.owin.ppp") export("as.owin.psp") export("as.owin.quad") export("as.owin.quadratcount") export("as.owin.tess") export("as.polygonal") export("as.ppp") export("as.ppp.data.frame") export("as.ppp.default") export("as.ppplist") export("as.ppp.matrix") export("as.ppp.ppp") export("as.ppp.psp") export("as.ppp.quad") export("as.psp") export("as.psp.data.frame") export("as.psp.default") export("as.psp.matrix") export("as.psp.owin") export("as.psp.psp") export("as.rectangle") export("as.solist") export("as.tess") export("as.tess.im") export("as.tess.list") export("as.tess.owin") export("as.tess.quadratcount") export("as.tess.tess") export("as.tess.tessfun") export("as.unitname") export("AsymmDistance.psp") export("avenndist") export("bbEngine") export("bdist.pixels") export("bdist.points") export("bdist.tiles") export("bdry.mask") export("beachcolourmap") export("beachcolours") export("border") export("boundingbox") export("bounding.box3") export("boundingbox.default") export("boundingbox.im") export("boundingbox.linnet") export("boundingbox.list") export("boundingbox.lpp") export("boundingbox.owin") export("boundingbox.ppp") export("boundingbox.psp") export("boundingbox.solist") export("bounding.box.xy") export("boundingcentre") export("boundingcentre.owin") export("boundingcentre.ppp") export("boundingcircle") export("boundingcircle.owin") export("boundingcircle.ppp") export("boundingradius") export("boundingradius.owin") export("boundingradius.ppp") export("box3") export("boxx") export("break.holes") export("bufftess") export("by.im") export("by.ppp") export("cartesian") export("cbind.hyperframe") export("cellmiddles") export("centroid.owin") export("check.arc") export("checkbigmatrix") export("checkfields") export("check.finespacing") export("chop.tess") export("circumradius") export("circumradius.owin") export("circumradius.ppp") export("circunion") export("clear.simplepanel") export("clickbox") export("clickdist") export("clickpoly") export("clickppp") export("clip.infline") export("clippoly.psp") export("clip.psp") export("cliprect.psp") export("closepairs") export("closepairs.pp3") export("closepairs.ppp") export("closethresh") export("closetriples") export("closing") export("closing.owin") export("closing.ppp") export("closing.psp") export("cobble.xy") export("cocoEngine") export("codetime") export("coerce.marks.numeric") export("col2hex") export("col.args.to.grey") export("colourmap") export("colouroutputs") export("colouroutputs<-") export("commonGrid") export("commonPolyclipArgs") export("compatible") export("compatible.im") export("compatible.unitname") export("complementarycolour") export("complement.owin") export("Complex.im") export("Complex.imlist") export("concatxy") export("conform.imagelist") export("connected") export("connected.im") export("connected.owin") export("connected.pp3") export("connected.ppp") export("connected.tess") export("contour.funxy") export("contour.im") export("contour.imlist") export("contour.listof") export("convexhull") export("convexhull.xy") export("convexify") export("convexmetric") export("convolve.im") export("coords") export("coords<-") export("coords.ppp") export("coords<-.ppp") export("coords.ppx") export("coords<-.ppx") export("coords.quad") export("corners") export("countingweights") export("covering") export("crossdist") export("crossdist.default") export("crossdist.pp3") export("crossdist.ppp") export("crossdist.ppx") export("crossdist.psp") export("crossing.psp") export("crosspairquad") export("crosspairs") export("crosspairs.pp3") export("crosspairs.ppp") export("cut.im") export("cut.ppp") export("default.dummy") export("default.image.colours") export("default.ntile") export("default.n.tiling") export("default.symbolmap") export("default.symbolmap.ppp") export("delaunay") export("delaunayDistance") export("deltametric") export("dflt.redraw") export("[.diagramobj") export("diagramobj") export("diameter") export("diameter.box3") export("diameter.boxx") export("diameter.owin") export("dilated.areas") export("dilation") export("dilationAny") export("dilation.owin") export("dilation.ppp") export("dilation.psp") export("dim.hyperframe") export("dim.im") export("dimnames.hyperframe") export("dimnames<-.hyperframe") export("dim.owin") export("dirichlet") export("dirichletAreas") export("dirichletEdges") export("dirichletVertices") export("dirichletWeights") export("disc") export("discpartarea") export("discretise") export("discs") export("dist2dpath") export("distfun") export("distfun.owin") export("distfun.ppp") export("distfun.psp") export("distmap") export("distmap.owin") export("distmap.ppp") export("distmap.psp") export("do.as.im") export("do.call.plotfun") export("domain") export("domain.distfun") export("domain.funxy") export("domain.im") export("domain.layered") export("domain.nnfun") export("domain.pp3") export("domain.ppp") export("domain.ppx") export("domain.psp") export("domain.quad") export("domain.quadratcount") export("domain.tess") export("drawSignedPoly") export("duplicated.ppp") export("duplicated.ppx") export("edges") export("edges2triangles") export("edges2vees") export("edit.hyperframe") export("edit.im") export("edit.ppp") export("edit.psp") export("ellipse") export("emptywindow") export("endpoints.psp") export("equalpairs.quad") export("equalsfun.quad") export("equals.quad") export("eroded.areas") export("eroded.volumes") export("eroded.volumes.box3") export("eroded.volumes.boxx") export("erodemask") export("erosion") export("erosionAny") export("erosion.owin") export("erosion.ppp") export("erosion.psp") export("eval.im") export("even.breaks.owin") export("exactdt") export("exactPdt") export("existsSpatstatVariable") export("expandSpecialLists") export("extrapolate.psp") export("fakemaintitle") export("fardist") export("fardist.owin") export("fardist.ppp") export("fft2D") export("fftwAvailable") export("fillNA") export("flipxy") export("flipxy.diagramobj") export("flipxy.distfun") export("flipxy.im") export("flipxy.infline") export("flipxy.layered") export("flipxy.owin") export("flipxypolygon") export("flipxy.ppp") export("flipxy.psp") export("flipxy.tess") export("format.numberwithunit") export("fourierbasis") export("fourierbasisraw") export("Frame") export("Frame<-") export("framebottomleft") export("Frame.default") export("Frame<-.default") export("framedist.pixels") export("framedist.pixels") export("Frame<-.im") export("Frame<-.owin") export("Frame<-.ppp") export("funxy") export("gammabreaks") export("genericNNdistBy") export("getfields") export("getlastshift") export("getSpatstatVariable") export("grid1index") export("gridcenters") export("gridcentres") export("gridindex") export("gridweights") export("grow.box3") export("grow.boxx") export("grow.mask") export("grow.rectangle") export("grow.simplepanel") export("Halton") export("Hammersley") export("handle.r.b.args") export("harmonise") export("harmonise.im") export("harmoniseLevels") export("harmonise.owin") export("harmonise.unitname") export("harmonize") export("harmonize.im") export("harmonize.owin") export("harmonize.unitname") export("has.close") export("has.close.default") export("has.close.pp3") export("has.close.ppp") export("head.hyperframe") export("head.ppp") export("head.ppx") export("head.psp") export("head.tess") export("hexagon") export("hexgrid") export("hextess") export("hist.funxy") export("hist.im") export("hsvim") export("hsvNA") export("[.hyperframe") export("[<-.hyperframe") export("[[.hyperframe") export("[[<-.hyperframe") export("hyperframe") export("identify.ppp") export("identify.psp") export("idorempty") export("[.im") export("[<-.im") export("im") export("image.im") export("image.imlist") export("image.listof") export("imagelistOp") export("imageOp") export("im.apply") export("imcov") export("incircle") export("infline") export("inpoint") export("inradius") export("inside.arc") export("inside.boxx") export("inside.owin") export("integral.im") export("integral.tessfun") export("intensity") export("intensity.ppp") export("intensity.ppx") export("intensity.psp") export("intensity.quadratcount") export("intensity.splitppp") export("interp.colourmap") export("interp.colours") export("interp.im") export("interpretAsOrigin") export("intersect.boxx") export("intersect.owin") export("intersect.tess") export("intX.owin") export("intX.xypolygon") export("intY.owin") export("intY.xypolygon") export("invokeColourmapRule") export("invoke.metric") export("invoke.symbolmap") export("is.boxx") export("is.col.argname") export("is.colour") export("is.connected") export("is.connected.default") export("is.connected.ppp") export("is.convex") export("is.data") export("is.empty") export("is.empty.default") export("is.empty.owin") export("is.empty.ppp") export("is.empty.psp") export("is.fv") export("is.grey") export("is.hyperframe") export("is.im") export("is.imlist") export("is.infline") export("is.linim") export("is.linnet") export("is.lpp") export("is.marked") export("is.marked.default") export("is.marked.ppp") export("is.marked.psp") export("is.marked.quad") export("is.mask") export("is.multitype") export("is.multitype.default") export("is.multitype.ppp") export("is.multitype.quad") export("is.owin") export("is.polygonal") export("is.pp3") export("is.ppp") export("is.ppplist") export("is.ppx") export("is.psp") export("is.quad") export("is.rectangle") export("is.sob") export("is.solist") export("is.subset.owin") export("is.tess") export("is.vanilla") export("[.layered") export("[<-.layered") export("[[<-.layered") export("layered") export("layerplotargs") export("layerplotargs<-") export("layout.boxes") export("lengths_psp") export("levelsAsFactor") export("levelset") export("levels.im") export("levels<-.im") export("[<-.listof") export("listof") export("logi.dummy") export("lookup.im") export("lut") export("majorminorversion") export("makeunitname") export("markappend") export("markappendop") export("markcbind") export("markformat") export("markformat.default") export("markformat.ppp") export("markformat.ppx") export("markformat.psp") export("markreplicateop") export("marks") export("marks<-") export("mark.scale.default") export("marks.default") export("markspace.integral") export("marks.ppp") export("marks<-.ppp") export("marks.ppx") export("marks<-.ppx") export("marks.psp") export("marks<-.psp") export("marks.quad") export("markstat") export("marks.tess") export("marks<-.tess") export("marksubset") export("marksubsetop") export("markvaluetype") export("mask2df") export("matchingdist") export("Math.im") export("Math.imlist") export("maxflow") export("maxnndist") export("mean.im") export("meanX.owin") export("meanY.owin") export("median.im") export("mergeLevels") export("midpoints.psp") export("MinimalTess") export("MinkowskiSum") export("minnndist") export("multiplicity") export("multiplicity.data.frame") export("multiplicity.default") export("multiplicityNumeric") export("multiplicity.ppp") export("multiplicity.ppx") export("multiply.only.finite.entries") export("na.handle.im") export("names.hyperframe") export("names<-.hyperframe") export("nearest.pixel") export("nearest.raster.point") export("nearestsegment") export("nearest.valid.pixel") export("nearestValue") export("nestsplit") export("nncross") export("nncross.default") export("nncross.pp3") export("nncross.ppp") export("nncross.ppx") export("nndist") export("nndist.default") export("nndist.pp3") export("nndist.ppp") export("nndist.ppx") export("nndist.psp") export("nnfun") export("nnfun.ppp") export("nnfun.psp") export("nnmap") export("nnmark") export("nnwhich") export("nnwhich.default") export("nnwhich.pp3") export("nnwhich.ppp") export("nnwhich.ppx") export("nobjects") export("nobjects.ppp") export("nobjects.ppx") export("nobjects.psp") export("nobjects.tess") export("npoints") export("npoints.pp3") export("npoints.ppp") export("npoints.ppx") export("n.quad") export("nsegments") export("nsegments.psp") export("numberwithunit") export("numeric.columns") export("nvertices") export("nvertices.default") export("nvertices.owin") export("onearrow") export("onecolumn") export("opening") export("opening.owin") export("opening.ppp") export("opening.psp") export("Ops.im") export("Ops.imlist") export("overlap.owin") export("[.owin") export("owin") export("owin2mask") export("owin2polypath") export("owinInternalMask") export("owinInternalPoly") export("owinInternalRect") export("owinpoly2mask") export("owinpolycheck") export("packupNNdata") export("padimage") export("pairdist") export("pairdist.default") export("pairdist.pp3") export("pairdist.ppp") export("pairdist.ppx") export("pairdist.psp") export("paletteindex") export("paletteindex") export("param.quad") export("parbreak") export("PDtoNN") export("perimeter") export("periodify") export("periodify.owin") export("periodify.ppp") export("periodify.psp") export("perspContour") export("persp.funxy") export("persp.im") export("perspLines") export("perspPoints") export("persp.ppp") export("perspSegments") export("perspVisible") export("pHcolour") export("pHcolourmap") export("pickoption") export("pixelcentres") export("pixellate") export("pixellate.owin") export("pixellate.ppp") export("pixellate.psp") export("pixelquad") export("plan.legend.layout") export("plot3Dpoints") export("plot.anylist") export("plot.barplotdata") export("plot.colourmap") export("plotEachLayer") export("plot.funxy") export("plot.hyperframe") export("plot.im") export("plot.imlist") export("plot.indicfun") export("plot.infline") export("plot.layered") export("plot.listof") export("plot.onearrow") export("plot.owin") export("plotPolygonBdry") export("plot.pp3") export("plot.ppp") export("plot.pppmatching") export("plot.ppx") export("plot.psp") export("plot.quad") export("plot.quadratcount") export("plot.solist") export("plot.splitppp") export("plot.symbolmap") export("plot.tess") export("plot.tessfun") export("plot.textstring") export("plot.texturemap") export("plotWidthMap") export("plot.yardstick") export("pointgrid") export("pointsOnLines") export("pointweights") export("polartess") export("polytileareaEngine") export("[.pp3") export("pp3") export("ppllengine") export("[.ppp") export("[<-.ppp") export("ppp") export("pppdist") export("pppdist.mat") export("pppdist.prohorov") export("pppmatching") export("ppsubset") export("[.ppx") export("ppx") export("prepareTitle") export("print.anylist") export("print.box3") export("print.boxx") export("print.colourmap") export("print.distfun") export("print.funxy") export("print.hyperframe") export("print.im") export("print.indicfun") export("print.infline") export("print.layered") export("print.lut") export("print.metric") export("print.metricfun") export("print.nnfun") export("print.numberwithunit") export("print.onearrow") export("print.owin") export("print.pp3") export("print.ppp") export("print.pppmatching") export("print.ppx") export("print.psp") export("print.quad") export("print.simplepanel") export("print.solist") export("print.splitppp") export("print.splitppx") export("print.summary.distfun") export("print.summary.funxy") export("print.summary.hyperframe") export("print.summary.im") export("print.summary.listof") export("print.summary.logiquad") export("print.summary.lut") export("print.summary.owin") export("print.summary.pp3") export("print.summary.ppp") export("print.summary.psp") export("print.summary.quad") export("print.summary.solist") export("print.summary.splitppp") export("print.summary.splitppx") export("print.summary.symbolmap") export("print.summary.unitname") export("print.symbolmap") export("print.tess") export("print.tessfun") export("print.textstring") export("print.texturemap") export("print.timed") export("print.unitname") export("print.yardstick") export("progressreport") export("project2segment") export("project2set") export("project3Dhom") export("[.psp") export("psp") export("psp2mask") export("putlastshift") export("putSpatstatVariable") export("qtPrepareCoordinate") export("[.quad") export("quad") export("quadratcount") export("quadratcount.ppp") export("quadratcount.splitppp") export("quadrats") export("quadscheme") export("quadscheme.logi") export("quadscheme.replicated") export("quadscheme.spatial") export("quantess") export("quantess.im") export("quantess.owin") export("quantess.ppp") export("quantilefun.im") export("quantile.im") export("rasterfilter") export("rastersample") export("raster.x") export("rasterx.im") export("rasterx.mask") export("raster.xy") export("rasterxy.im") export("rasterxy.mask") export("raster.y") export("rastery.im") export("rastery.mask") export("rbind.hyperframe") export("rebound") export("rebound.im") export("rebound.owin") export("rebound.ppp") export("rebound.psp") export("recognise.spatstat.type") export("rectdistmap") export("rectquadrat.breaks") export("rectquadrat.countEngine") export("redraw.simplepanel") export("reflect") export("reflect.default") export("reflect.diagramobj") export("reflect.distfun") export("reflect.im") export("reflect.infline") export("reflect.layered") export("reflect.tess") export("regularpolygon") export("relevel.im") export("relevel.ppp") export("relevel.ppx") export("remove.identical.pairs") export("repair.image.xycoords") export("repair.old.factor.image") export("requireversion") export("rescale") export("rescale.distfun") export("rescale.im") export("rescale.layered") export("rescale.owin") export("rescale.ppp") export("rescale.psp") export("rescale.unitname") export("rescue.rectangle") export("reset.default.image.colours") export("reset.spatstat.options") export("resolve.stringsAsFactors") export("restrict.colourmap") export("restrict.mask") export("rev.colourmap") export("reversePolyclipArgs") export("rexplode") export("rexplode.ppp") export("rgb2hex") export("rgb2hsva") export("rgbim") export("rgbNA") export("ripras") export("rjitter") export("rjitter.ppp") export("rlinegrid") export("rotate") export("rotate.diagramobj") export("rotate.distfun") export("rotate.im") export("rotate.infline") export("rotate.layered") export("rotate.owin") export("rotate.ppp") export("rotate.psp") export("rotate.tess") export("rotxy") export("rotxypolygon") export("rounding.pp3") export("rounding.ppp") export("rounding.ppx") export("round.pp3") export("round.ppp") export("round.ppx") export("row.names.hyperframe") export("row.names<-.hyperframe") export("rQuasi") export("rsyst") export("ruletextline") export("runifrect") export("run.simplepanel") export("safedeldir") export("safeDevCapabilities") export("safelookup") export("samecolour") export("scalardilate") export("scalardilate.breakpts") export("scalardilate.default") export("scalardilate.diagramobj") export("scalardilate.distfun") export("scalardilate.im") export("scalardilate.layered") export("scalardilate.owin") export("scalardilate.ppp") export("scalardilate.psp") export("scalardilate.tess") export("scale.boxx") export("scale.ppx") export("scaletointerval") export("scaletointerval.default") export("scaletointerval.im") export("scanpp") export("selfcrossing.psp") export("selfcut.psp") export("sessionLibs") export("setcov") export("setmarks") export("setminus.owin") export("shift") export("shift.boxx") export("shift.diagramobj") export("shift.distfun") export("shift.im") export("shift.infline") export("shift.layered") export("shift.owin") export("shift.ppp") export("shift.ppx") export("shift.psp") export("shift.quadratcount") export("shift.tess") export("shiftxy") export("shiftxypolygon") export("shortside") export("shortside.box3") export("shortside.boxx") export("shortside.owin") export("sidelengths") export("sidelengths.box3") export("sidelengths.boxx") export("sidelengths.owin") export("simplepanel") export("simplify.owin") export("simulationresult") export("smudge") export("solapply") export("[.solist") export("[<-.solist") export("solist") export("solutionset") export("sort.im") export("spatdim") export("spatstat.deldir.setopt") export("spatstatDiagnostic") export("spatstat.options") export("spatstat.xy.coords") export("split.hyperframe") export("split<-.hyperframe") export("split.im") export("[.splitppp") export("[<-.splitppp") export("split.ppp") export("split<-.ppp") export("[.splitppx") export("[<-.splitppx") export("split.ppx") export("spokes") export("square") export("store.versionstring.spatstat") export("stratrand") export("str.hyperframe") export("subset.hyperframe") export("subset.pp3") export("subset.ppp") export("subset.ppx") export("subset.psp") export("summary.anylist") export("summary.distfun") export("summary.funxy") export("summary.hyperframe") export("summary.im") export("Summary.im") export("Summary.imlist") export("summary.listof") export("summary.logiquad") export("summary.lut") export("summary.metric") export("summary.owin") export("summary.pp3") export("summary.ppp") export("summary.pppmatching") export("summary.ppx") export("summary.psp") export("summary.quad") export("summary.solist") export("summary.splitppp") export("summary.splitppx") export("summary.symbolmap") export("summary.unitname") export("superimpose") export("superimpose.default") export("superimposeMarks") export("superimpose.ppp") export("superimpose.ppplist") export("superimpose.psp") export("superimpose.splitppp") export("symbolmap") export("symbolmapdomain") export("symbolmapparnames") export("symbolmaptype") export("symbol.sizes.default") export("tail.hyperframe") export("tail.ppp") export("tail.ppx") export("tail.psp") export("tail.tess") export("[.tess") export("[<-.tess") export("tess") export("tessfunvalues") export("test.crossing.psp") export("test.selfcrossing.psp") export("text.ppp") export("text.psp") export("textstring") export("texturemap") export("textureplot") export("thickSegments") export("tile.areas") export("tilecentroids") export("tileindex") export("tilenames") export("tilenames<-") export("tilenames.tess") export("tilenames<-.tess") export("tiles") export("tiles.empty") export("timed") export("timeTaken") export("to.grey") export("to.opaque") export("to.saturated") export("to.transparent") export("transmat") export("trianglediameters") export("triangulate.owin") export("trim.mask") export("trim.rectangle") export("tweak.closepairs") export("tweak.colourmap") export("union.owin") export("union.quad") export("uniquemap.lpp") export("uniquemap.ppp") export("uniquemap.ppx") export("unique.ppp") export("unique.ppx") export("unitname") export("unitname<-") export("unitname.box3") export("unitname<-.box3") export("unitname.boxx") export("unitname<-.boxx") export("unitname.default") export("unitname<-.default") export("unitname.im") export("unitname<-.im") export("unitname.owin") export("unitname<-.owin") export("unitname.pp3") export("unitname<-.pp3") export("unitname.ppp") export("unitname<-.ppp") export("unitname.ppx") export("unitname<-.ppx") export("unitname.psp") export("unitname<-.psp") export("unitname.quad") export("unitname<-.quad") export("unitname.tess") export("unitname<-.tess") export("unit.square") export("unmark") export("unmark.ppp") export("unmark.ppx") export("unmark.psp") export("unmark.splitppp") export("unmark.tess") export("unstackFilter") export("unstack.layered") export("unstack.ppp") export("unstack.psp") export("unstack.solist") export("unstack.tess") export("update.im") export("update.symbolmap") export("validate.mask") export("validate.quad") export("validradius") export("vdCorput") export("venn.tess") export("verifyclass") export("versioncurrency.spatstat") export("versionstring.spatstat") export("vertices") export("vertices.owin") export("veryunique") export("volume") export("volume.box3") export("volume.boxx") export("volume.owin") export("warn.no.metric.support") export("warn.once") export("warn.unsupported.args") export("waxlyrical") export("where.max") export("where.min") export("whichhalfplane") export("Window") export("Window<-") export("Window.distfun") export("Window.funxy") export("Window.im") export("Window<-.im") export("Window.layered") export("Window.nnfun") export("Window.ppp") export("Window<-.ppp") export("Window.psp") export("Window<-.psp") export("Window.quad") export("Window<-.quad") export("Window.quadratcount") export("Window.tess") export("with.hyperframe") export("w.quad") export("wrangle2image") export("XDtoNN") export("x.quad") export("xtfrm.im") export("xy.grid") export("xypolygon2psp") export("xypolyselfint") export("yardstick") export("y.quad") export("zapsmall.im") export("ZeroValue") export("ZeroValue.im") # ....... Special cases ........... export("%(+)%") export("%(-)%") export("%mapp%") export("%mark%") export("%mrep%") export("%msub%") export("%unit%") S3method("Complex", "im") S3method("Complex", "imlist") S3method("Math", "im") S3method("Math", "imlist") S3method("mean", "im") S3method("median", "im") S3method("Ops", "im") S3method("Ops", "imlist") S3method("Summary", "im") S3method("Summary", "imlist") # ....... End of special cases ... # ......................................... # Automatically generated list of S3 methods # ......................................... S3method("$", "hyperframe") S3method("affine", "diagramobj") S3method("affine", "distfun") S3method("affine", "im") S3method("affine", "layered") S3method("affine", "owin") S3method("affine", "ppp") S3method("affine", "psp") S3method("affine", "tess") S3method("anyDuplicated", "ppp") S3method("anyDuplicated", "ppx") S3method("[", "anylist") S3method("anyNA", "im") S3method("area", "default") S3method("area", "owin") S3method("as.array", "im") S3method("as.character", "unitname") S3method("as.colourmap", "colourmap") S3method("as.colourmap", "symbolmap") S3method("as.data.frame", "hyperframe") S3method("as.data.frame", "im") S3method("as.data.frame", "owin") S3method("as.data.frame", "ppp") S3method("as.data.frame", "ppplist") S3method("as.data.frame", "ppx") S3method("as.data.frame", "psp") S3method("as.data.frame", "tess") S3method("as.double", "im") S3method("as.function", "im") S3method("as.function", "owin") S3method("as.function", "tess") S3method("as.hyperframe", "anylist") S3method("as.hyperframe", "data.frame") S3method("as.hyperframe", "default") S3method("as.hyperframe", "hyperframe") S3method("as.hyperframe", "listof") S3method("as.hyperframe", "ppx") S3method("as.im", "data.frame") S3method("as.im", "default") S3method("as.im", "distfun") S3method("as.im", "expression") S3method("as.im", "function") S3method("as.im", "funxy") S3method("as.im", "im") S3method("as.im", "matrix") S3method("as.im", "nnfun") S3method("as.im", "owin") S3method("as.im", "ppp") S3method("as.im", "tess") S3method("as.layered", "default") S3method("as.layered", "listof") S3method("as.layered", "ppp") S3method("as.layered", "solist") S3method("as.layered", "splitppp") S3method("as.list", "hyperframe") S3method("as.matrix", "im") S3method("as.matrix", "owin") S3method("as.matrix", "ppx") S3method("as.owin", "boxx") S3method("as.owin", "data.frame") S3method("as.owin", "default") S3method("as.owin", "distfun") S3method("as.owin", "funxy") S3method("as.owin", "im") S3method("as.owin", "layered") S3method("as.owin", "nnfun") S3method("as.owin", "owin") S3method("as.owin", "ppp") S3method("as.owin", "psp") S3method("as.owin", "quad") S3method("as.owin", "quadratcount") S3method("as.owin", "tess") S3method("as.ppp", "data.frame") S3method("as.ppp", "default") S3method("as.ppp", "matrix") S3method("as.ppp", "ppp") S3method("as.ppp", "psp") S3method("as.ppp", "quad") S3method("as.psp", "data.frame") S3method("as.psp", "default") S3method("as.psp", "matrix") S3method("as.psp", "owin") S3method("as.psp", "psp") S3method("as.tess", "im") S3method("as.tess", "list") S3method("as.tess", "owin") S3method("as.tess", "quadratcount") S3method("as.tess", "tess") S3method("as.tess", "tessfun") S3method("boundingbox", "default") S3method("boundingbox", "im") S3method("boundingbox", "linnet") S3method("boundingbox", "list") S3method("boundingbox", "lpp") S3method("boundingbox", "owin") S3method("boundingbox", "ppp") S3method("boundingbox", "psp") S3method("boundingbox", "solist") S3method("boundingcentre", "owin") S3method("boundingcentre", "ppp") S3method("boundingcircle", "owin") S3method("boundingcircle", "ppp") S3method("boundingradius", "owin") S3method("boundingradius", "ppp") S3method("by", "im") S3method("by", "ppp") S3method("cbind", "hyperframe") S3method("circumradius", "owin") S3method("circumradius", "ppp") S3method("closepairs", "pp3") S3method("closepairs", "ppp") S3method("closing", "owin") S3method("closing", "ppp") S3method("closing", "psp") S3method("compatible", "im") S3method("compatible", "unitname") S3method("connected", "im") S3method("connected", "owin") S3method("connected", "pp3") S3method("connected", "ppp") S3method("connected", "tess") S3method("contour", "funxy") S3method("contour", "im") S3method("contour", "imlist") S3method("contour", "listof") S3method("coords", "ppp") S3method("coords", "ppx") S3method("coords", "quad") S3method("crossdist", "default") S3method("crossdist", "pp3") S3method("crossdist", "ppp") S3method("crossdist", "ppx") S3method("crossdist", "psp") S3method("crosspairs", "pp3") S3method("crosspairs", "ppp") S3method("cut", "im") S3method("cut", "ppp") S3method("default.symbolmap", "ppp") S3method("[", "diagramobj") S3method("diameter", "box3") S3method("diameter", "boxx") S3method("diameter", "owin") S3method("dilation", "owin") S3method("dilation", "ppp") S3method("dilation", "psp") S3method("dim", "hyperframe") S3method("dim", "im") S3method("dimnames", "hyperframe") S3method("dim", "owin") S3method("distfun", "owin") S3method("distfun", "ppp") S3method("distfun", "psp") S3method("distmap", "owin") S3method("distmap", "ppp") S3method("distmap", "psp") S3method("domain", "distfun") S3method("domain", "funxy") S3method("domain", "im") S3method("domain", "layered") S3method("domain", "nnfun") S3method("domain", "pp3") S3method("domain", "ppp") S3method("domain", "ppx") S3method("domain", "psp") S3method("domain", "quad") S3method("domain", "quadratcount") S3method("domain", "tess") S3method("duplicated", "ppp") S3method("duplicated", "ppx") S3method("edit", "hyperframe") S3method("edit", "im") S3method("edit", "ppp") S3method("edit", "psp") S3method("eroded.volumes", "box3") S3method("eroded.volumes", "boxx") S3method("erosion", "owin") S3method("erosion", "ppp") S3method("erosion", "psp") S3method("fardist", "owin") S3method("fardist", "ppp") S3method("flipxy", "diagramobj") S3method("flipxy", "distfun") S3method("flipxy", "im") S3method("flipxy", "infline") S3method("flipxy", "layered") S3method("flipxy", "owin") S3method("flipxy", "ppp") S3method("flipxy", "psp") S3method("flipxy", "tess") S3method("format", "numberwithunit") S3method("Frame", "default") S3method("harmonise", "im") S3method("harmonise", "owin") S3method("harmonise", "unitname") S3method("harmonize", "im") S3method("harmonize", "owin") S3method("harmonize", "unitname") S3method("has.close", "default") S3method("has.close", "pp3") S3method("has.close", "ppp") S3method("head", "hyperframe") S3method("head", "ppp") S3method("head", "ppx") S3method("head", "psp") S3method("head", "tess") S3method("hist", "funxy") S3method("hist", "im") S3method("[", "hyperframe") S3method("[[", "hyperframe") S3method("identify", "ppp") S3method("identify", "psp") S3method("[", "im") S3method("image", "im") S3method("image", "imlist") S3method("image", "listof") S3method("integral", "im") S3method("integral", "tessfun") S3method("intensity", "ppp") S3method("intensity", "ppx") S3method("intensity", "psp") S3method("intensity", "quadratcount") S3method("intensity", "splitppp") S3method("is.connected", "default") S3method("is.connected", "ppp") S3method("is.empty", "default") S3method("is.empty", "owin") S3method("is.empty", "ppp") S3method("is.empty", "psp") S3method("is.marked", "default") S3method("is.marked", "ppp") S3method("is.marked", "psp") S3method("is.marked", "quad") S3method("is.multitype", "default") S3method("is.multitype", "ppp") S3method("is.multitype", "quad") S3method("[", "layered") S3method("levels", "im") S3method("markformat", "default") S3method("markformat", "ppp") S3method("markformat", "ppx") S3method("markformat", "psp") S3method("marks", "default") S3method("marks", "ppp") S3method("marks", "ppx") S3method("marks", "psp") S3method("marks", "quad") S3method("marks", "tess") S3method("multiplicity", "data.frame") S3method("multiplicity", "default") S3method("multiplicity", "ppp") S3method("multiplicity", "ppx") S3method("names", "hyperframe") S3method("nncross", "default") S3method("nncross", "pp3") S3method("nncross", "ppp") S3method("nncross", "ppx") S3method("nndist", "default") S3method("nndist", "pp3") S3method("nndist", "ppp") S3method("nndist", "ppx") S3method("nndist", "psp") S3method("nnfun", "ppp") S3method("nnfun", "psp") S3method("nnwhich", "default") S3method("nnwhich", "pp3") S3method("nnwhich", "ppp") S3method("nnwhich", "ppx") S3method("nobjects", "ppp") S3method("nobjects", "ppx") S3method("nobjects", "psp") S3method("nobjects", "tess") S3method("npoints", "pp3") S3method("npoints", "ppp") S3method("npoints", "ppx") S3method("nsegments", "psp") S3method("nvertices", "default") S3method("nvertices", "owin") S3method("opening", "owin") S3method("opening", "ppp") S3method("opening", "psp") S3method("[", "owin") S3method("pairdist", "default") S3method("pairdist", "pp3") S3method("pairdist", "ppp") S3method("pairdist", "ppx") S3method("pairdist", "psp") S3method("periodify", "owin") S3method("periodify", "ppp") S3method("periodify", "psp") S3method("persp", "funxy") S3method("persp", "im") S3method("persp", "ppp") S3method("pixellate", "owin") S3method("pixellate", "ppp") S3method("pixellate", "psp") S3method("plot", "anylist") S3method("plot", "barplotdata") S3method("plot", "colourmap") S3method("plot", "funxy") S3method("plot", "hyperframe") S3method("plot", "im") S3method("plot", "imlist") S3method("plot", "indicfun") S3method("plot", "infline") S3method("plot", "layered") S3method("plot", "listof") S3method("plot", "onearrow") S3method("plot", "owin") S3method("plot", "pp3") S3method("plot", "ppp") S3method("plot", "pppmatching") S3method("plot", "ppx") S3method("plot", "psp") S3method("plot", "quad") S3method("plot", "quadratcount") S3method("plot", "solist") S3method("plot", "splitppp") S3method("plot", "symbolmap") S3method("plot", "tess") S3method("plot", "tessfun") S3method("plot", "textstring") S3method("plot", "texturemap") S3method("plot", "yardstick") S3method("[", "pp3") S3method("[", "ppp") S3method("[", "ppx") S3method("print", "anylist") S3method("print", "box3") S3method("print", "boxx") S3method("print", "colourmap") S3method("print", "distfun") S3method("print", "funxy") S3method("print", "hyperframe") S3method("print", "im") S3method("print", "indicfun") S3method("print", "infline") S3method("print", "layered") S3method("print", "lut") S3method("print", "metric") S3method("print", "metricfun") S3method("print", "nnfun") S3method("print", "numberwithunit") S3method("print", "onearrow") S3method("print", "owin") S3method("print", "pp3") S3method("print", "ppp") S3method("print", "pppmatching") S3method("print", "ppx") S3method("print", "psp") S3method("print", "quad") S3method("print", "simplepanel") S3method("print", "solist") S3method("print", "splitppp") S3method("print", "splitppx") S3method("print", "summary.distfun") S3method("print", "summary.funxy") S3method("print", "summary.hyperframe") S3method("print", "summary.im") S3method("print", "summary.listof") S3method("print", "summary.logiquad") S3method("print", "summary.lut") S3method("print", "summary.owin") S3method("print", "summary.pp3") S3method("print", "summary.ppp") S3method("print", "summary.psp") S3method("print", "summary.quad") S3method("print", "summary.solist") S3method("print", "summary.splitppp") S3method("print", "summary.splitppx") S3method("print", "summary.symbolmap") S3method("print", "summary.unitname") S3method("print", "symbolmap") S3method("print", "tess") S3method("print", "tessfun") S3method("print", "textstring") S3method("print", "texturemap") S3method("print", "timed") S3method("print", "unitname") S3method("print", "yardstick") S3method("[", "psp") S3method("[", "quad") S3method("quadratcount", "ppp") S3method("quadratcount", "splitppp") S3method("quantess", "im") S3method("quantess", "owin") S3method("quantess", "ppp") S3method("quantilefun", "im") S3method("quantile", "im") S3method("rbind", "hyperframe") S3method("rebound", "im") S3method("rebound", "owin") S3method("rebound", "ppp") S3method("rebound", "psp") S3method("reflect", "default") S3method("reflect", "diagramobj") S3method("reflect", "distfun") S3method("reflect", "im") S3method("reflect", "infline") S3method("reflect", "layered") S3method("reflect", "tess") S3method("relevel", "im") S3method("relevel", "ppp") S3method("relevel", "ppx") S3method("rescale", "distfun") S3method("rescale", "im") S3method("rescale", "layered") S3method("rescale", "owin") S3method("rescale", "ppp") S3method("rescale", "psp") S3method("rescale", "unitname") S3method("rev", "colourmap") S3method("rexplode", "ppp") S3method("rjitter", "ppp") S3method("rotate", "diagramobj") S3method("rotate", "distfun") S3method("rotate", "im") S3method("rotate", "infline") S3method("rotate", "layered") S3method("rotate", "owin") S3method("rotate", "ppp") S3method("rotate", "psp") S3method("rotate", "tess") S3method("rounding", "pp3") S3method("rounding", "ppp") S3method("rounding", "ppx") S3method("round", "pp3") S3method("round", "ppp") S3method("round", "ppx") S3method("row.names", "hyperframe") S3method("scalardilate", "breakpts") S3method("scalardilate", "default") S3method("scalardilate", "diagramobj") S3method("scalardilate", "distfun") S3method("scalardilate", "im") S3method("scalardilate", "layered") S3method("scalardilate", "owin") S3method("scalardilate", "ppp") S3method("scalardilate", "psp") S3method("scalardilate", "tess") S3method("scale", "boxx") S3method("scale", "ppx") S3method("scaletointerval", "default") S3method("scaletointerval", "im") S3method("shift", "boxx") S3method("shift", "diagramobj") S3method("shift", "distfun") S3method("shift", "im") S3method("shift", "infline") S3method("shift", "layered") S3method("shift", "owin") S3method("shift", "ppp") S3method("shift", "ppx") S3method("shift", "psp") S3method("shift", "quadratcount") S3method("shift", "tess") S3method("shortside", "box3") S3method("shortside", "boxx") S3method("shortside", "owin") S3method("sidelengths", "box3") S3method("sidelengths", "boxx") S3method("sidelengths", "owin") S3method("[", "solist") S3method("sort", "im") S3method("split", "hyperframe") S3method("split", "im") S3method("[", "splitppp") S3method("split", "ppp") S3method("split", "ppx") S3method("[", "splitppx") S3method("str", "hyperframe") S3method("subset", "hyperframe") S3method("subset", "pp3") S3method("subset", "ppp") S3method("subset", "ppx") S3method("subset", "psp") S3method("summary", "anylist") S3method("summary", "distfun") S3method("summary", "funxy") S3method("summary", "hyperframe") S3method("summary", "im") S3method("summary", "listof") S3method("summary", "logiquad") S3method("summary", "lut") S3method("summary", "metric") S3method("summary", "owin") S3method("summary", "pp3") S3method("summary", "ppp") S3method("summary", "pppmatching") S3method("summary", "ppx") S3method("summary", "psp") S3method("summary", "quad") S3method("summary", "solist") S3method("summary", "splitppp") S3method("summary", "splitppx") S3method("summary", "symbolmap") S3method("summary", "unitname") S3method("superimpose", "default") S3method("superimpose", "ppp") S3method("superimpose", "ppplist") S3method("superimpose", "psp") S3method("superimpose", "splitppp") S3method("tail", "hyperframe") S3method("tail", "ppp") S3method("tail", "ppx") S3method("tail", "psp") S3method("tail", "tess") S3method("[", "tess") S3method("text", "ppp") S3method("text", "psp") S3method("tilenames", "tess") S3method("uniquemap", "lpp") S3method("uniquemap", "ppp") S3method("uniquemap", "ppx") S3method("unique", "ppp") S3method("unique", "ppx") S3method("unitname", "box3") S3method("unitname", "boxx") S3method("unitname", "default") S3method("unitname", "im") S3method("unitname", "owin") S3method("unitname", "pp3") S3method("unitname", "ppp") S3method("unitname", "ppx") S3method("unitname", "psp") S3method("unitname", "quad") S3method("unitname", "tess") S3method("unmark", "ppp") S3method("unmark", "ppx") S3method("unmark", "psp") S3method("unmark", "splitppp") S3method("unmark", "tess") S3method("unstack", "layered") S3method("unstack", "ppp") S3method("unstack", "psp") S3method("unstack", "solist") S3method("unstack", "tess") S3method("update", "im") S3method("update", "symbolmap") S3method("vertices", "owin") S3method("volume", "box3") S3method("volume", "boxx") S3method("volume", "owin") S3method("Window", "distfun") S3method("Window", "funxy") S3method("Window", "im") S3method("Window", "layered") S3method("Window", "nnfun") S3method("Window", "ppp") S3method("Window", "psp") S3method("Window", "quad") S3method("Window", "quadratcount") S3method("Window", "tess") S3method("with", "hyperframe") S3method("xtfrm", "im") S3method("ZeroValue", "im") # ......................................... # Assignment methods # ......................................... S3method("$<-", "hyperframe") S3method("[<-", "anylist") S3method("coords<-", "ppp") S3method("coords<-", "ppx") S3method("dimnames<-", "hyperframe") S3method("Frame<-", "default") S3method("Frame<-", "im") S3method("Frame<-", "owin") S3method("Frame<-", "ppp") S3method("[<-", "hyperframe") S3method("[[<-", "hyperframe") S3method("[<-", "im") S3method("[<-", "layered") S3method("[[<-", "layered") S3method("levels<-", "im") S3method("[<-", "listof") S3method("marks<-", "ppp") S3method("marks<-", "ppx") S3method("marks<-", "psp") S3method("marks<-", "tess") S3method("names<-", "hyperframe") S3method("[<-", "ppp") S3method("row.names<-", "hyperframe") S3method("[<-", "solist") S3method("split<-", "hyperframe") S3method("[<-", "splitppp") S3method("split<-", "ppp") S3method("[<-", "splitppx") S3method("[<-", "tess") S3method("tilenames<-", "tess") S3method("unitname<-", "box3") S3method("unitname<-", "boxx") S3method("unitname<-", "default") S3method("unitname<-", "im") S3method("unitname<-", "owin") S3method("unitname<-", "pp3") S3method("unitname<-", "ppp") S3method("unitname<-", "ppx") S3method("unitname<-", "psp") S3method("unitname<-", "quad") S3method("unitname<-", "tess") S3method("Window<-", "im") S3method("Window<-", "ppp") S3method("Window<-", "psp") S3method("Window<-", "quad") # ......................................... # End of methods # ......................................... spatstat.geom/inst/0000755000176200001440000000000014634220675014031 5ustar liggesusersspatstat.geom/inst/CITATION0000755000176200001440000000357114611065351015170 0ustar liggesusersc( bibentry(bibtype = "Book", title = "Spatial Point Patterns: Methodology and Applications with {R}", author = c(person("Adrian", "Baddeley"), person("Ege", "Rubak"), person("Rolf", "Turner")), year = "2015", publisher = "Chapman and Hall/CRC Press", address = "London", isbn = 9781482210200, url = "https://www.routledge.com/Spatial-Point-Patterns-Methodology-and-Applications-with-R/Baddeley-Rubak-Turner/p/book/9781482210200/", header = "To cite spatstat in publications, please use:" ), bibentry(bibtype = "Article", title = "Hybrids of Gibbs Point Process Models and Their Implementation", author = c(person("Adrian", "Baddeley"), person("Rolf", "Turner"), person("Jorge", "Mateu"), person("Andrew", "Bevan")), journal = "Journal of Statistical Software", year = "2013", volume = "55", number = "11", pages = "1--43", doi = "10.18637/jss.v055.i11", header = "If you use hybrid models, please also cite:" ), bibentry(bibtype = "Article", title = "{spatstat}: An {R} Package for Analyzing Spatial Point Patterns", author = c(person("Adrian", "Baddeley"), person("Rolf", "Turner")), journal = "Journal of Statistical Software", year = "2005", volume = "12", number = "6", pages = "1--42", doi = "10.18637/jss.v012.i06", header = "In survey articles, please also cite the original paper on spatstat:" ) ) spatstat.geom/inst/info/0000755000176200001440000000000014634220675014764 5ustar liggesusersspatstat.geom/inst/info/packagesizes.txt0000755000176200001440000000270014766135011020173 0ustar liggesusersdate version nhelpfiles nobjects ndatasets Rlines srclines "2020-12-14" "1.65-0" 433 1158 0 33577 15156 "2021-01-09" "1.65-1" 433 1158 0 33606 15157 "2021-01-12" "1.65-4" 433 1158 0 33612 15157 "2021-02-17" "1.65-7" 433 1158 0 33614 15157 "2021-03-07" "1.65-8" 433 1158 0 33614 15104 "2021-03-19" "2.0-1" 433 1158 0 33616 15104 "2021-04-15" "2.1-0" 433 1158 0 33674 15115 "2021-06-15" "2.2-0" 434 1159 0 33744 15115 "2021-10-09" "2.3-0" 440 1175 0 34553 15173 "2021-12-10" "2.3-1" 440 1176 0 34643 15173 "2022-02-12" "2.3-2" 440 1176 0 34657 15173 "2022-03-28" "2.4-0" 441 1178 0 34804 15188 "2022-10-22" "3.0-0" 442 1182 0 35107 15531 "2022-10-23" "3.0-3" 442 1182 0 35107 15596 "2023-01-22" "3.0-5" 445 1190 0 35297 15596 "2023-01-30" "3.0-6" 445 1190 0 35307 15596 "2023-03-12" "3.1-0" 449 1199 0 35694 15596 "2023-05-09" "3.2-0" 449 1200 0 35837 15596 "2023-05-09" "3.2-1" 450 1202 0 35837 15621 "2023-07-03" "3.2-2" 450 1202 0 35864 15621 "2023-07-20" "3.2-3" 450 1203 0 35915 15747 "2023-07-20" "3.2-4" 450 1203 0 35915 15747 "2023-09-05" "3.2-5" 450 1203 0 35948 15822 "2023-10-19" "3.2-6" 451 1203 0 35983 15822 "2023-10-20" "3.2-7" 451 1203 0 35983 15822 "2024-01-26" "3.2-8" 452 1204 0 36234 15822 "2024-02-28" "3.2-9" 452 1209 0 36325 15824 "2024-07-05" "3.3-0" 442 1186 0 35638 15596 "2024-07-09" "3.3-2" 442 1186 0 35638 15596 "2024-09-18" "3.3-3" 443 1187 0 35818 15596 "2024-11-18" "3.3-4" 444 1190 0 35978 15596 "2025-03-18" "3.3-6" 446 1196 0 36273 15596 spatstat.geom/inst/doc/0000755000176200001440000000000014645352433014576 5ustar liggesusersspatstat.geom/inst/doc/packagesizes.txt0000755000176200001440000000270014766135011020005 0ustar liggesusersdate version nhelpfiles nobjects ndatasets Rlines srclines "2020-12-14" "1.65-0" 433 1158 0 33577 15156 "2021-01-09" "1.65-1" 433 1158 0 33606 15157 "2021-01-12" "1.65-4" 433 1158 0 33612 15157 "2021-02-17" "1.65-7" 433 1158 0 33614 15157 "2021-03-07" "1.65-8" 433 1158 0 33614 15104 "2021-03-19" "2.0-1" 433 1158 0 33616 15104 "2021-04-15" "2.1-0" 433 1158 0 33674 15115 "2021-06-15" "2.2-0" 434 1159 0 33744 15115 "2021-10-09" "2.3-0" 440 1175 0 34553 15173 "2021-12-10" "2.3-1" 440 1176 0 34643 15173 "2022-02-12" "2.3-2" 440 1176 0 34657 15173 "2022-03-28" "2.4-0" 441 1178 0 34804 15188 "2022-10-22" "3.0-0" 442 1182 0 35107 15531 "2022-10-23" "3.0-3" 442 1182 0 35107 15596 "2023-01-22" "3.0-5" 445 1190 0 35297 15596 "2023-01-30" "3.0-6" 445 1190 0 35307 15596 "2023-03-12" "3.1-0" 449 1199 0 35694 15596 "2023-05-09" "3.2-0" 449 1200 0 35837 15596 "2023-05-09" "3.2-1" 450 1202 0 35837 15621 "2023-07-03" "3.2-2" 450 1202 0 35864 15621 "2023-07-20" "3.2-3" 450 1203 0 35915 15747 "2023-07-20" "3.2-4" 450 1203 0 35915 15747 "2023-09-05" "3.2-5" 450 1203 0 35948 15822 "2023-10-19" "3.2-6" 451 1203 0 35983 15822 "2023-10-20" "3.2-7" 451 1203 0 35983 15822 "2024-01-26" "3.2-8" 452 1204 0 36234 15822 "2024-02-28" "3.2-9" 452 1209 0 36325 15824 "2024-07-05" "3.3-0" 442 1186 0 35638 15596 "2024-07-09" "3.3-2" 442 1186 0 35638 15596 "2024-09-18" "3.3-3" 443 1187 0 35818 15596 "2024-11-18" "3.3-4" 444 1190 0 35978 15596 "2025-03-18" "3.3-6" 446 1196 0 36273 15596 spatstat.geom/inst/doc/downstream.txt0000644000176200001440000000004314611065354017513 0ustar liggesusersPackage Version "spatstat" "2.0-0" spatstat.geom/inst/ratfor/0000755000176200001440000000000014611065354015322 5ustar liggesusersspatstat.geom/inst/ratfor/dppll.r0000755000176200001440000000203314611065354016621 0ustar liggesuserssubroutine dppll(x,y,l1,l2,l3,l4,np,nl,eps,mint,rslt,xmin,jmin) implicit double precision(a-h,o-z) dimension x(np), y(np), rslt(np,nl), xmin(np), jmin(np) double precision l1(nl), l2(nl), l3(nl), l4(nl) one = 1.d0 zero = 0.d0 do j = 1,nl { dx = l3(j) - l1(j) dy = l4(j) - l2(j) alen = sqrt(dx**2 + dy**2) if(alen .gt. eps) { co = dx/alen si = dy/alen } else { co = 0.5 si = 0.5 } do i = 1, np { xpx1 = x(i) - l1(j) ypy1 = y(i) - l2(j) xpx2 = x(i) - l3(j) ypy2 = y(i) - l4(j) d1 = xpx1**2 + ypy1**2 d2 = xpx2**2 + ypy2**2 dd = min(d1,d2) if(alen .gt. eps) { xpr = xpx1*co + ypy1*si if(xpr .lt. zero .or. xpr .gt. alen) { d3 = -one } else { ypr = - xpx1*si + ypy1*co d3 = ypr**2 } } else { d3 = -one } if(d3 .ge. zero) { dd = min(dd,d3) } sd =sqrt(dd) rslt(i,j) = sd if(mint.gt.0) { if(sd .lt. xmin(i)) { xmin(i) = sd if(mint.gt.1) { jmin(i) = j } } } } } return end spatstat.geom/inst/ratfor/inxypOld.r0000755000176200001440000000216314611065354017320 0ustar liggesuserssubroutine inxyp(x,y,xp,yp,npts,nedges,score,onbndry) implicit double precision(a-h,o-z) dimension x(npts), y(npts), xp(nedges), yp(nedges), score(npts) logical first, onbndry(npts) zero = 0.0d0 half = 0.5d0 one = 1.0d0 do i = 1,nedges { x0 = xp(i) y0 = yp(i) if(i == nedges) { x1 = xp(1) y1 = yp(1) } else { x1 = xp(i+1) y1 = yp(i+1) } dx = x1 - x0 dy = y1 - y0 do j = 1,npts { xcrit = (x(j) - x0)*(x(j) - x1) if(xcrit <= zero) { if(xcrit == zero) { contrib = half } else { contrib = one } ycrit = y(j)*dx - x(j)*dy + x0*dy - y0*dx if(dx < 0) { if(ycrit >= zero) { score(j) = score(j) + contrib } onbndry(j) = onbndry(j) | (ycrit == zero) } else if(dx > zero) { if(ycrit < zero) { score(j) = score(j) - contrib } onbndry(j) = onbndry(j) | (ycrit == zero) } else { if(x(j) == x0) { ycrit = (y(j) - y0)*(y(j) - y1) } onbndry(j) = onbndry(j) | (ycrit <= zero) } } } } return end spatstat.geom/inst/ratfor/Makefile0000755000176200001440000000244414766135012016771 0ustar liggesusers RATFOR = /home/adrian/bin/ratfor77 #RATFOR = /usr/local/bin/ratfor CPP = /usr/bin/cpp ########################################################## # Sources actually written by humans: RAT_SRC = dppll.r inxypOld.r C_DOMINIC = dinfty.c dwpure.c C_MISC = raster.h areadiff.c closepair.c connect.c corrections.c \ discarea.c distances.c distmapbin.c distseg.c \ exactdist.c exactPdist.c \ massdisthack.c poly2im.c trigraf.c utils.c xyseg.c C_MH = methas.h dist2.h areaint.c badgey.c dgs.c \ diggra.c dist2.c fexitc.c getcif.c geyer.c \ lookup.c methas.c stfcr.c \ straush.c straushm.c strauss.c straussm.c C_KEST = Kloop.h Kborder.c C_SRC = $(C_DOMINIC) $(C_MISC) $(C_MH) $(C_KEST) CC_SRC = PerfectStrauss.cc HUMAN = $(RAT_SRC) $(C_SRC) $(CC_SRC) Makefile ########################################################## # Source to be generated automatically: RAT_FOR = dppll.f inxypOld.f GENERATED = $(RAT_FOR) ###################################################### ########### TARGETS ################################ target: $(GENERATED) @echo -- Done ------- tar: tar cvf src.tar $(HUMAN) clean: rm $(GENERATED) -rm src.tar ####################################################### ######### RULES ################################## .r.f: $(RATFOR) -o $@ $? spatstat.geom/man/0000755000176200001440000000000014765164151013630 5ustar liggesusersspatstat.geom/man/quad.object.Rd0000644000176200001440000000573714611065350016321 0ustar liggesusers\name{quad.object} \alias{quad.object} %DoNotExport \title{Class of Quadrature Schemes} \description{ A class \code{"quad"} to represent a quadrature scheme. } \details{ A (finite) quadrature scheme is a list of quadrature points \eqn{u_j}{u[j]} and associated weights \eqn{w_j}{w[j]} which is used to approximate an integral by a finite sum: \deqn{ \int f(x) dx \approx \sum_j f(u_j) w_j }{ integral(f(x) dx) ~= sum( f(u[j]) w[j] ) } Given a point pattern dataset, a \emph{Berman-Turner} quadrature scheme is one which includes all these data points, as well as a nonzero number of other (``dummy'') points. These quadrature schemes are used to approximate the pseudolikelihood of a point process, in the method of Baddeley and Turner (2000) (see Berman and Turner (1992)). Accuracy and computation time both increase with the number of points in the quadrature scheme. An object of class \code{"quad"} represents a Berman-Turner quadrature scheme. It can be passed as an argument to the model-fitting function \code{\link[spatstat.model]{ppm}}, which requires a quadrature scheme. An object of this class contains at least the following elements: \tabular{ll}{ \code{data}: \tab an object of class \code{"ppp"} \cr \tab giving the locations (and marks) of the data points.\cr \code{dummy}: \tab an object of class \code{"ppp"} \cr \tab giving the locations (and marks) of the dummy points.\cr \code{w}: \tab vector of nonnegative weights for the quadrature points\cr } Users are strongly advised not to manipulate these entries directly. The domain of quadrature is specified by \code{Window(dummy)} while the observation window (if this needs to be specified separately) is taken to be \code{Window(data)}. The weights vector \code{w} may also have an attribute \code{attr(w, "zeroes")} equivalent to the logical vector \code{(w == 0)}. If this is absent then all points are known to have positive weights. To create an object of class \code{"quad"}, users would typically call the high level function \code{\link{quadscheme}}. (They are actually created by the low level function \code{quad}.) Entries are extracted from a \code{"quad"} object by the functions \code{x.quad}, \code{y.quad}, \code{w.quad} and \code{marks.quad}, which extract the \eqn{x} coordinates, \eqn{y} coordinates, weights, and marks, respectively. The function \code{n.quad} returns the total number of quadrature points (dummy plus data). An object of class \code{"quad"} can be converted into an ordinary point pattern by the function \code{\link{union.quad}} which simply takes the union of the data and dummy points. Quadrature schemes can be plotted using \code{\link{plot.quad}} (a method for the generic \code{\link{plot}}). } \seealso{ \code{\link{quadscheme}}, \code{\link[spatstat.model]{ppm}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{attribute} spatstat.geom/man/progressreport.Rd0000644000176200001440000001223014611065350017204 0ustar liggesusers\name{progressreport} \alias{progressreport} \title{Print Progress Reports} \description{ Prints Progress Reports during a loop or iterative calculation. } \usage{ progressreport(i, n, every = min(100,max(1, ceiling(n/100))), tick = 1, nperline = NULL, charsperline = getOption("width"), style = spatstat.options("progress"), showtime = NULL, state=NULL, formula = (time ~ i), savehistory=FALSE) } \arguments{ \item{i}{ Integer. The current iteration number (from 1 to \code{n}). } \item{n}{ Integer. The (maximum) number of iterations to be computed. } \item{every}{ Optional integer. Iteration number will be printed when \code{i} is a multiple of \code{every}. } \item{tick}{ Optional integer. A tick mark or dot will be printed when \code{i} is a multiple of \code{tick}. } \item{nperline}{ Optional integer. Number of iterations per line of output. } \item{charsperline}{ Optional integer. The number of characters in a line of output. } \item{style}{ Character string determining the style of display. Options are \code{"tty"} (the default), \code{"tk"} and \code{"txtbar"}. See Details. } \item{showtime}{ Optional. Logical value indicating whether to print the estimated time remaining. Applies only when \code{style="tty"}. } \item{state}{ Optional. A list containing the internal data. } \item{formula}{ Optional. A model formula expressing the expected relationship between the iteration number \code{i} and the clock time \code{time}. Used for predicting the time remaining. } \item{savehistory}{ Optional. Logical value indicating whether to save the elapsed times at which \code{progressreport} was called. } } \details{ This is a convenient function for reporting progress during an iterative sequence of calculations or a suite of simulations. \itemize{ \item If \code{style="tk"} then \code{tcltk::tkProgressBar} is used to pop-up a new graphics window showing a progress bar. This requires the package \pkg{tcltk}. As \code{i} increases from 1 to \code{n}, the bar will lengthen. The arguments \code{every, tick, nperline, showtime} are ignored. \item If \code{style="txtbar"} then \code{\link[utils]{txtProgressBar}} is used to represent progress as a bar made of text characters in the \R interpreter window. As \code{i} increases from 1 to \code{n}, the bar will lengthen. The arguments \code{every, tick, nperline, showtime} are ignored. \item If \code{style="tty"} (the default), then progress reports are printed to the console. This only seems to work well under Linux. As \code{i} increases from 1 to \code{n}, the output will be a sequence of dots (one dot for every \code{tick} iterations), iteration numbers (printed when iteration number is a multiple of \code{every} or is less than 4), and optionally the estimated time remaining and the estimated completion time. The estimated time remaining will be printed only if \code{style="tty"}, and the argument \code{state} is given, and either \code{showtime=TRUE}, or \code{showtime=NULL} and the iterations are slow (defined as: the estimated time remaining is longer than 3 minutes, or the average time per iteration is longer than 20 seconds). The estimated completion time will be printed only if the estimated time remaining is printed and the remaining time is longer than 10 minutes. By default, the estimated time remaining is calculated by assuming that each iteration takes the same amount of time, and extrapolating. Alternatively, if the argument \code{formula} is given, then it should be a model formula, stating the expected relationship between the iteration number \code{i} and the clock time \code{time}. This model will be fitted to the history of clock times recorded so far, and used to predict the time remaining. (The default formula states that clock time is a linear function of the iteration number, which is equivalent to assuming that each iteration takes the same amount of time.) } It is optional, but strongly advisable, to use the argument \code{state} to store and update the internal data for the progress reports (such as the cumulative time taken for computation) as shown in the last example below. This avoids conflicts with other programs that might be calling \code{progressreport} at the same time. } \value{ If \code{state} was \code{NULL}, the result is \code{NULL}. Otherwise the result is the updated value of \code{state}. } \author{ \spatstatAuthors. } \examples{ for(i in 1:40) { # # code that does something... # progressreport(i, 40) } # saving internal state: *recommended* sta <- list() for(i in 1:20) { # some code ... sta <- progressreport(i, 20, state=sta) } #' use text progress bar sta <- list() for(i in 1:10) { # some code ... sta <- progressreport(i, 10, state=sta, style="txtbar") } } \keyword{print} spatstat.geom/man/nndist.psp.Rd0000644000176200001440000000631714742317357016231 0ustar liggesusers\name{nndist.psp} \alias{nndist.psp} \title{Nearest neighbour distances between line segments} \description{ Computes the distance from each line segment to its nearest neighbour in a line segment pattern. Alternatively finds the distance to the second nearest, third nearest etc. } \usage{ \method{nndist}{psp}(X, \dots, k=1, method="C") } \arguments{ \item{X}{ A line segment pattern (object of class \code{"psp"}). } \item{\dots}{ Ignored. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } \item{method}{ String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. Usually not specified. } } \value{ Numeric vector or matrix containing the nearest neighbour distances for each line segment. If \code{k = 1} (the default), the return value is a numeric vector \code{v} such that \code{v[i]} is the nearest neighbour distance for the \code{i}th segment. If \code{k} is a single integer, then the return value is a numeric vector \code{v} such that \code{v[i]} is the \code{k}th nearest neighbour distance for the \code{i}th segment. If \code{k} is a vector, then the return value is a matrix \code{m} such that \code{m[i,j]} is the \code{k[j]}th nearest neighbour distance for the \code{i}th segment. } \details{ This is a method for the generic function \code{\link{nndist}} for the class \code{"psp"}. If \code{k=1}, this function computes the distance from each line segment to the nearest other line segment in \code{X}. In general it computes the distance from each line segment to the \code{k}th nearest other line segment. The argument \code{k} can also be a vector, and this computation will be performed for each value of \code{k}. Distances are calculated using the Hausdorff metric. The Hausdorff distance between two line segments is the maximum distance from any point on one of the segments to the nearest point on the other segment. If there are fewer than \code{max(k)+1} line segments in the pattern, some of the nearest neighbour distances will be infinite (\code{Inf}). The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted \R code only. If \code{method="C"} (the default) then compiled \code{C} code is used. The \code{C} code is somewhat faster. } \section{Distance values}{ The values returned by \code{nndist(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{nndist(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{nndist}}, \code{\link{nndist.ppp}} } \examples{ L <- psp(runif(10), runif(10), runif(10), runif(10), owin()) D <- nndist(L) D <- nndist(L, k=1:3) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/Replace.im.Rd0000644000176200001440000001142014611065350016063 0ustar liggesusers\name{Replace.im} \alias{[<-.im} \title{Reset Values in Subset of Image} \description{ Reset the values in a subset of a pixel image. } \usage{ \method{[}{im}(x, i, j, \dots, drop=TRUE) <- value } \arguments{ \item{x}{ A two-dimensional pixel image. An object of class \code{"im"}. } \item{i}{ Object defining the subregion or subset to be replaced. Either a spatial window (an object of class \code{"owin"}), or a pixel image with logical values, or a point pattern (an object of class \code{"ppp"}), or any type of index that applies to a matrix, or something that can be converted to a point pattern by \code{\link{as.ppp}} (using the window of \code{x}). } \item{j}{ An integer or logical vector serving as the column index if matrix indexing is being used. Ignored if \code{i} is appropriate to some sort of replacement \emph{other than} matrix indexing. } \item{\dots}{Ignored.} \item{drop}{ Logical value specifying what happens when \code{i} and \code{j} are both missing. See Details. } \item{value}{ Vector, matrix, factor or pixel image containing the replacement values. Short vectors will be recycled. } } \value{ The image \code{x} with the values replaced. } \details{ This function changes some of the pixel values in a pixel image. The image \code{x} must be an object of class \code{"im"} representing a pixel image defined inside a rectangle in two-dimensional space (see \code{\link{im.object}}). The subset to be changed is determined by the arguments \code{i,j} according to the following rules (which are checked in this order): \enumerate{ \item \code{i} is a spatial object such as a window, a pixel image with logical values, or a point pattern; or \item \code{i,j} are indices for the matrix \code{as.matrix(x)}; or \item \code{i} can be converted to a point pattern by \code{\link{as.ppp}(i, W=Window(x))}, and \code{i} is not a matrix. } If \code{i} is a spatial window (an object of class \code{"owin"}), the values of the image inside this window are changed. If \code{i} is a point pattern (an object of class \code{"ppp"}), then the values of the pixel image at the points of this pattern are changed. If \code{i} does not satisfy any of the conditions above, then the algorithm tries to interpret \code{i,j} as indices for the matrix \code{as.matrix(x)}. Either \code{i} or \code{j} may be missing or blank. If none of the conditions above are met, and if \code{i} is not a matrix, then \code{i} is converted into a point pattern by \code{\link{as.ppp}(i, W=Window(x))}. Again the values of the pixel image at the points of this pattern are changed. If \code{i} and \code{j} are both missing, as in the call \code{x[] <- value}, then all pixel values in \code{x} are replaced by \code{value}: \itemize{ \item If \code{drop=TRUE} (the default), then this replacement applies only to pixels whose values are currently defined (i.e. where the current pixel value is not \code{NA}). If \code{value} is a vector, then its length must equal the number of pixels whose values are currently defined. \item If \code{drop=FALSE} then the replacement applies to all pixels inside the rectangle \code{Frame(x)}. If \code{value} is a vector, then its length must equal the number of pixels in the entire rectangle. } } \section{Warning}{ If you have a 2-column matrix containing the \eqn{x,y} coordinates of point locations, then to prevent this being interpreted as an array index, you should convert it to a \code{data.frame} or to a point pattern. } \seealso{ \code{\link{im.object}}, \code{\link{[.im}}, \code{\link{[}}, \code{\link{ppp.object}}, \code{\link{as.ppp}}, \code{\link{owin.object}} } \examples{ # make up an image X <- setcov(unit.square()) plot(X) # a rectangular subset W <- owin(c(0,0.5),c(0.2,0.8)) X[W] <- 2 plot(X) # a polygonal subset R <- affine(letterR, diag(c(1,1)/2), c(-2,-0.7)) X[R] <- 3 plot(X) # a point pattern X[cells] <- 10 plot(X) # change pixel value at a specific location X[list(x=0.1,y=0.2)] <- 7 # matrix indexing --- single vector index X[1:2570] <- 10 plot(X) # matrix indexing using double indices X[1:257,1:10] <- 5 plot(X) # matrix indexing using a matrix of indices X[cbind(1:257,1:257)] <- 10 X[cbind(257:1,1:257)] <- 10 plot(X) # Blank indices Y <- as.im(letterR) plot(Y) Y[] <- 42 # replace values only inside the window 'R' plot(Y) Y[drop=FALSE] <- 7 # replace all values in the rectangle plot(Y) Z <- as.im(letterR) Z[] <- raster.x(Z, drop=TRUE) # excludes NA plot(Z) Z[drop=FALSE] <- raster.y(Z, drop=FALSE) # includes NA plot(Z) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/diameter.owin.Rd0000644000176200001440000000204414611065346016660 0ustar liggesusers\name{diameter.owin} \alias{diameter.owin} \title{Diameter of a Window} \description{ Computes the diameter of a window. } \usage{ \method{diameter}{owin}(x) } \arguments{ \item{x}{ A window whose diameter will be computed. } } \value{ The numerical value of the diameter of the window. } \details{ This function computes the diameter of a window of arbitrary shape, i.e. the maximum distance between any two points in the window. The argument \code{x} should be a window (an object of class \code{"owin"}, see \code{\link{owin.object}} for details) or can be given in any format acceptable to \code{\link{as.owin}()}. The function \code{diameter} is generic. This function is the method for the class \code{"owin"}. } \seealso{ \code{\link{area.owin}}, \code{\link{perimeter}}, \code{\link{edges}}, \code{\link{owin}}, \code{\link{as.owin}} } \examples{ w <- owin(c(0,1),c(0,1)) diameter(w) # returns sqrt(2) diameter(letterR) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/concatxy.Rd0000644000176200001440000000225514611065345015746 0ustar liggesusers\name{concatxy} \alias{concatxy} \title{Concatenate x,y Coordinate Vectors} \description{ Concatenate any number of pairs of \code{x} and \code{y} coordinate vectors. } \usage{ concatxy(\dots) } \arguments{ \item{\dots}{ Any number of arguments, each of which is a structure containing elements \code{x} and \code{y}. } } \value{ A list with two components \code{x} and \code{y}, which are the concatenations of all the corresponding \code{x} and \code{y} vectors in the argument list. } \details{ This function can be used to superimpose two or more point patterns of unmarked points (but see also \code{\link{superimpose}} which is recommended). It assumes that each of the arguments in \code{\dots} is a structure containing (at least) the elements \code{x} and \code{y}. It concatenates all the \code{x} elements into a vector \code{x}, and similarly for \code{y}, and returns these concatenated vectors. } \seealso{ \code{\link{superimpose}}, \code{\link{quadscheme}} } \examples{ dat <- runifrect(30) xy <- list(x=runif(10),y=runif(10)) new <- concatxy(dat, xy) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/closepairs.Rd0000644000176200001440000001316314611065345016262 0ustar liggesusers\name{closepairs} \alias{closepairs} \alias{crosspairs} \alias{closepairs.ppp} \alias{crosspairs.ppp} \title{ Close Pairs of Points } \description{ Low-level functions to find all close pairs of points. } \usage{ closepairs(X, rmax, \dots) \method{closepairs}{ppp}(X, rmax, twice=TRUE, what=c("all","indices","ijd"), distinct=TRUE, neat=TRUE, periodic=FALSE, \dots) crosspairs(X, Y, rmax, \dots) \method{crosspairs}{ppp}(X, Y, rmax, what=c("all", "indices", "ijd"), periodic=FALSE, \dots, iX=NULL, iY=NULL) } \arguments{ \item{X,Y}{ Point patterns (objects of class \code{"ppp"}). } \item{rmax}{ Maximum distance between pairs of points to be counted as close pairs. } \item{twice}{ Logical value indicating whether all ordered pairs of close points should be returned. If \code{twice=TRUE} (the default), each pair will appear twice in the output, as \code{(i,j)} and again as \code{(j,i)}. If \code{twice=FALSE}, then each pair will appear only once, as the pair \code{(i,j)} with \code{i < j}. } \item{what}{ String specifying the data to be returned for each close pair of points. If \code{what="all"} (the default) then the returned information includes the indices \code{i,j} of each pair, their \code{x,y} coordinates, and the distance between them. If \code{what="indices"} then only the indices \code{i,j} are returned. If \code{what="ijd"} then the indices \code{i,j} and the distance \code{d} are returned. } \item{distinct}{ Logical value indicating whether to return only the pairs of points with different indices \code{i} and \code{j} (\code{distinct=TRUE}, the default) or to also include the pairs where \code{i=j} (\code{distinct=FALSE}). } \item{neat}{ Logical value indicating whether to ensure that \code{i < j} in each output pair, when \code{twice=FALSE}. } \item{periodic}{ Logical value indicating whether to use the periodic edge correction. The window of \code{X} should be a rectangle. Opposite pairs of edges of the window will be treated as identical. } \item{\dots}{Extra arguments, ignored by methods.} \item{iX,iY}{ Optional vectors used to determine whether a point in \code{X} is identical to a point in \code{Y}. See Details. } } \details{ These are the efficient low-level functions used by \pkg{spatstat} to find all close pairs of points in a point pattern or all close pairs between two point patterns. \code{closepairs(X,rmax)} finds all pairs of distinct points in the pattern \code{X} which lie at a distance less than or equal to \code{rmax} apart, and returns them. The result is a list with the following components: \describe{ \item{i}{Integer vector of indices of the first point in each pair.} \item{j}{Integer vector of indices of the second point in each pair.} \item{xi,yi}{Coordinates of the first point in each pair.} \item{xj,yj}{Coordinates of the second point in each pair.} \item{dx}{Equal to \code{xj-xi}} \item{dy}{Equal to \code{yj-yi}} \item{d}{Euclidean distance between each pair of points.} } If \code{what="indices"} then only the components \code{i} and \code{j} are returned. This is slightly faster and more efficient with use of memory. \code{crosspairs(X,rmax)} identifies all pairs of neighbours \code{(X[i], Y[j])} between the patterns \code{X} and \code{Y}, and returns them. The result is a list with the same format as for \code{closepairs}. The arguments \code{iX} and \code{iY} are used when the two point patterns \code{X} and \code{Y} may have some points in common. In this situation \code{crosspairs(X, Y)} would return some pairs of points in which the two points are identical. To avoid this, attach a unique integer identifier to each point, such that two points are identical if their identifier values are equal. Let \code{iX} be the vector of identifier values for the points in \code{X}, and \code{iY} the vector of identifiers for points in \code{Y}. Then the code will only compare two points if they have different values of the identifier. } \section{Warning about accuracy}{ The results of these functions may not agree exactly with the correct answer (as calculated by a human) and may not be consistent between different computers and different installations of \R. The discrepancies arise in marginal cases where the interpoint distance is equal to, or very close to, the threshold \code{rmax}. Floating-point numbers in a computer are not mathematical Real Numbers: they are approximations using finite-precision binary arithmetic. The approximation is accurate to a tolerance of about \code{.Machine$double.eps}. If the true interpoint distance \eqn{d} and the threshold \code{rmax} are equal, or if their difference is no more than \code{.Machine$double.eps}, the result may be incorrect. } \value{ A list with components \code{i} and \code{j}, and possibly other components as described under Details. } \author{ \adrian and \rolf } \seealso{ \code{\link{closepairs.pp3}} for the corresponding functions for 3D point patterns. \code{\link[spatstat.explore]{Kest}}, \code{\link[spatstat.explore]{Kcross}}, \code{\link{nndist}}, \code{\link{nncross}}, \code{\link{applynbd}}, \code{\link{markstat}} for functions which use these capabilities. } \examples{ d <- closepairs(cells, 0.1) head(as.data.frame(d)) Y <- split(amacrine) e <- crosspairs(Y$on, Y$off, 0.1) } \keyword{spatial} \keyword{math} spatstat.geom/man/convexmetric.Rd0000644000176200001440000000415114611065345016621 0ustar liggesusers\name{convexmetric} \alias{convexmetric} \title{ Distance Metric Defined by Convex Set } \description{ Create the distance metric associated with a given convex polygon. } \usage{ convexmetric(K) } \arguments{ \item{K}{ Convex set defining the metric. A polygon that is symmetric about the origin. See Details. } } \details{ This function creates the distance metric associated with the convex set \code{K} so that the unit ball of the metric is equal to \code{K}. It returns an object of class \code{"metric"} representing the metric (see \code{\link{metric.object}}). The argument \code{K} must be a window (class \code{"owin"}). It will be converted to a polygon. It must be convex, and symmetric about the origin. To perform distance calculations (for example, nearest-neighbour distances) using this metric instead of the Euclidean metric, first check whether the standard function for this purpose (for example \code{nndist.ppp}) has an argument named \code{metric}. If so, use the standard function and add the argument \code{metric}; if not, use the low-level function \code{\link{invoke.metric}}. To see which operations are currently supported by the metric, use \code{summary}, as shown in the examples. } \value{ An object of class \code{"metric"}. } \author{ \adrian } \seealso{ \code{\link{metric.object}}, \code{\link{invoke.metric}} } \examples{ K <- owin(poly=list(x=c(2.5,2,0.5,-2.5,-2,-0.5),y=c(0,1,2,0,-1,-2))) plot(K) points(0,0) m <- convexmetric(K) m summary(m) ## show redwood data and identify point number 43 plot(redwood, main="") plot(redwood[43], pch=16, add=TRUE) ## compute nearest neighbour distances and identifiers ## using the distance metric m nd <- nndist(redwood, metric=m) nw <- nnwhich(redwood, metric=m) ## Nearest neighbour distance for point number 43 is nd[43]; verify B43 <- disc(radius=nd[43], centre=redwood[43], metric=m) plot(B43, add=TRUE) ## nearest neighbour for point number 43 is point number nw[43]; verify plot(redwood[nw[43]], pch=3, col="red", add=TRUE) } \keyword{spatial} \keyword{math} spatstat.geom/man/as.boxx.Rd0000644000176200001440000000217414611065345015500 0ustar liggesusers\name{as.boxx} \alias{as.boxx} \title{Convert Data to Multi-Dimensional Box} \description{Interprets data as the dimensions of a multi-dimensional box.} \usage{ as.boxx(\dots, warn.owin = TRUE) } \arguments{ \item{\dots}{ Data that can be interpreted as giving the dimensions of a multi-dimensional box. See Details. } \item{warn.owin}{ Logical value indicating whether to print a warning if a non-rectangular window (object of class \code{"owin"}) is supplied. } } \details{ Either a single argument should be provided which is one of the following: \itemize{ \item an object of class \code{"boxx"} \item an object of class \code{"box3"} \item an object of class \code{"owin"} \item a numeric vector of even length, specifying the corners of the box. See Examples } or a list of arguments acceptable to \code{\link{boxx}}. } \value{A \code{"boxx"} object.} \author{ \adrian \rolf and \ege } \examples{ # Convert unit square to two dimensional box. W <- owin() as.boxx(W) # Make three dimensional box [0,1]x[0,1]x[0,1] from numeric vector as.boxx(c(0,1,0,1,0,1)) } spatstat.geom/man/pairdist.default.Rd0000644000176200001440000000664214611065347017366 0ustar liggesusers\name{pairdist.default} \alias{pairdist.default} \title{Pairwise distances} \description{ Computes the matrix of distances between all pairs of points in a set of points in two dimensional space } \usage{ \method{pairdist}{default}(X, Y=NULL, \dots, period=NULL, method="C", squared=FALSE) } \arguments{ \item{X,Y}{ Arguments specifying the coordinates of a set of points. Typically \code{X} and \code{Y} would be numeric vectors of equal length. Alternatively \code{Y} may be omitted and \code{X} may be a list with two components \code{x} and \code{y}, or a matrix with two columns. } \item{\dots}{ Ignored. } \item{period}{ Optional. Dimensions for periodic edge correction. } \item{method}{ String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. Usually not specified. } \item{squared}{ Logical. If \code{squared=TRUE}, the squared distances are returned instead (this computation is faster). } } \value{ A square matrix whose \code{[i,j]} entry is the distance between the points numbered \code{i} and \code{j}. } \details{ Given the coordinates of a set of points in two dimensional space, this function computes the Euclidean distances between all pairs of points, and returns the matrix of distances. It is a method for the generic function \code{pairdist}. Note: If only pairwise distances within some threshold value are needed the low-level function \code{\link{closepairs}} may be much faster to use. The arguments \code{X} and \code{Y} must determine the coordinates of a set of points. Typically \code{X} and \code{Y} would be numeric vectors of equal length. Alternatively \code{Y} may be omitted and \code{X} may be a list with two components named \code{x} and \code{y}, or a matrix or data frame with two columns. For typical input the result is numerically equivalent to (but computationally faster than) \code{as.matrix(dist(x))} where \code{x = cbind(X, Y)}, but that command is useful for calculating all pairwise distances between points in \eqn{k}-dimensional space when \code{x} has \eqn{k} columns. Alternatively if \code{period} is given, then the distances will be computed in the `periodic' sense (also known as `torus' distance). The points will be treated as if they are in a rectangle of width \code{period[1]} and height \code{period[2]}. Opposite edges of the rectangle are regarded as equivalent. If \code{squared=TRUE} then the \emph{squared} Euclidean distances \eqn{d^2} are returned, instead of the Euclidean distances \eqn{d}. The squared distances are faster to calculate, and are sufficient for many purposes (such as finding the nearest neighbour of a point). The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted R code only. If \code{method="C"} (the default) then C code is used. The C code is somewhat faster. } \seealso{ \code{\link{crossdist}}, \code{\link{nndist}}, \code{\link[spatstat.explore]{Kest}}, \code{\link{closepairs}} } \examples{ x <- runif(100) y <- runif(100) d <- pairdist(x, y) d <- pairdist(cbind(x,y)) d <- pairdist(x, y, period=c(1,1)) d <- pairdist(x, y, squared=TRUE) } \author{ \pavel and \adrian. } \keyword{spatial} \keyword{math} spatstat.geom/man/im.Rd0000644000176200001440000001165714611065346014532 0ustar liggesusers\name{im} \alias{im} \title{Create a Pixel Image Object} \description{ Creates an object of class \code{"im"} representing a two-dimensional pixel image. } \usage{ im(mat, xcol=seq_len(ncol(mat)), yrow=seq_len(nrow(mat)), xrange=NULL, yrange=NULL, unitname=NULL) } \arguments{ \item{mat}{ matrix or vector containing the pixel values of the image. } \item{xcol}{ vector of \eqn{x} coordinates for the pixel grid } \item{yrow}{ vector of \eqn{y} coordinates for the pixel grid } \item{xrange,yrange}{ Optional. Vectors of length 2 giving the \eqn{x} and \eqn{y} limits of the enclosing rectangle. (Ignored if \code{xcol}, \code{yrow} are present.) } \item{unitname}{ Optional. Name of unit of length. Either a single character string, or a vector of two character strings giving the singular and plural forms, respectively. } } \details{ This function creates an object of class \code{"im"} representing a \sQuote{pixel image} or two-dimensional array of values. The pixel grid is rectangular and occupies a rectangular window in the spatial coordinate system. The pixel values are \emph{scalars}: they can be real numbers, integers, complex numbers, single characters or strings, logical values, or categorical values. A pixel's value can also be \code{NA}, meaning that no value is defined at that location, and effectively that pixel is \sQuote{outside} the window. Although the pixel values must be scalar, photographic colour images (i.e., with red, green, and blue brightness channels) can be represented as character-valued images in \pkg{spatstat}, using \R's standard encoding of colours as character strings. The matrix \code{mat} contains the \sQuote{greyscale} values for a rectangular grid of pixels. Note carefully that the entry \code{mat[i,j]} gives the pixel value at the location \code{(xcol[j],yrow[i])}. That is, the \bold{row} index of the matrix \code{mat} corresponds to increasing \bold{y} coordinate, while the column index of \code{mat} corresponds to increasing \bold{x} coordinate. Thus \code{yrow} has one entry for each row of \code{mat} and \code{xcol} has one entry for each column of \code{mat}. Under the usual convention in \R, a correct display of the image would be obtained by transposing the matrix, e.g. \code{image.default(xcol, yrow, t(mat))}, if you wanted to do it by hand. The entries of \code{mat} may be numeric (real or integer), complex, logical, character, or factor values. If \code{mat} is not a matrix, it will be converted into a matrix with \code{nrow(mat) = length(yrow)} and \code{ncol(mat) = length(xcol)}. To make a factor-valued image, note that \R has a quirky way of handling matrices with factor-valued entries. The command \code{\link{matrix}} cannot be used directly, because it destroys factor information. To make a factor-valued image, do one of the following: \itemize{ \item Create a \code{factor} containing the pixel values, say \code{mat <- factor(.....)}, and then assign matrix dimensions to it by \code{dim(mat) <- c(nr, nc)} where \code{nr, nc} are the numbers of rows and columns. The resulting object \code{mat} is both a factor and a vector. \item Supply \code{mat} as a one-dimensional factor and specify the arguments \code{xcol} and \code{yrow} to determine the dimensions of the image. \item Use the functions \code{\link{cut.im}} or \code{\link{eval.im}} to make factor-valued images from other images). } For a description of the methods available for pixel image objects, see \code{\link{im.object}}. To convert other kinds of data to a pixel image (for example, functions or windows), use \code{\link{as.im}}. } \seealso{ \code{\link{im.object}} for details of the class. \code{\link{as.im}} for converting other kinds of data to an image. \code{\link{as.matrix.im}}, \code{\link{[.im}}, \code{\link{eval.im}} for manipulating images. } \section{Warnings}{ The internal representation of images is likely to change in future releases of \pkg{spatstat}. The safe way to extract pixel values from an image object is to use \code{\link{as.matrix.im}} or \code{\link{[.im}}. } \examples{ vec <- rnorm(1200) mat <- matrix(vec, nrow=30, ncol=40) whitenoise <- im(mat) whitenoise <- im(mat, xrange=c(0,1), yrange=c(0,1)) whitenoise <- im(mat, xcol=seq(0,1,length=40), yrow=seq(0,1,length=30)) whitenoise <- im(vec, xcol=seq(0,1,length=40), yrow=seq(0,1,length=30)) plot(whitenoise) # Factor-valued images: f <- factor(letters[1:12]) dim(f) <- c(3,4) Z <- im(f) # Factor image from other image: cutwhite <- cut(whitenoise, 3) plot(cutwhite) # Factor image from raw data cutmat <- cut(mat, 3) dim(cutmat) <- c(30,40) cutwhite <- im(cutmat) plot(cutwhite) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} \keyword{datagen} spatstat.geom/man/applynbd.Rd0000644000176200001440000002016414611065345015726 0ustar liggesusers\name{applynbd} \alias{applynbd} \title{Apply Function to Every Neighbourhood in a Point Pattern} \description{ Visit each point in a point pattern, find the neighbouring points, and apply a given function to them. } \usage{ applynbd(X, FUN, N=NULL, R=NULL, criterion=NULL, exclude=FALSE, \dots) } \arguments{ \item{X}{ Point pattern. An object of class \code{"ppp"}, or data which can be converted into this format by \code{\link{as.ppp}}. } \item{FUN}{ Function to be applied to each neighbourhood. The arguments of \code{FUN} are described under \bold{Details}. } \item{N}{ Integer. If this argument is present, the neighbourhood of a point of \code{X} is defined to consist of the \code{N} points of \code{X} which are closest to it. } \item{R}{ Nonnegative numeric value. If this argument is present, the neighbourhood of a point of \code{X} is defined to consist of all points of \code{X} which lie within a distance \code{R} of it. } \item{criterion}{ Function. If this argument is present, the neighbourhood of a point of \code{X} is determined by evaluating this function. See under \bold{Details}. } \item{exclude}{ Logical. If \code{TRUE} then the point currently being visited is excluded from its own neighbourhood. } \item{\dots}{ extra arguments passed to the function \code{FUN}. They must be given in the form \code{name=value}. } } \value{ Similar to the result of \code{\link{apply}}. If each call to \code{FUN} returns a single numeric value, the result is a vector of dimension \code{npoints(X)}, the number of points in \code{X}. If each call to \code{FUN} returns a vector of the same length \code{m}, then the result is a matrix of dimensions \code{c(m,n)}; note the transposition of the indices, as usual for the family of \code{apply} functions. If the calls to \code{FUN} return vectors of different lengths, the result is a list of length \code{npoints(X)}. } \details{ This is an analogue of \code{\link{apply}} for point patterns. It visits each point in the point pattern \code{X}, determines which points of \code{X} are ``neighbours'' of the current point, applies the function \code{FUN} to this neighbourhood, and collects the values returned by \code{FUN}. The definition of ``neighbours'' depends on the arguments \code{N}, \code{R} and \code{criterion}. Also the argument \code{exclude} determines whether the current point is excluded from its own neighbourhood. \itemize{ \item If \code{N} is given, then the neighbours of the current point are the \code{N} points of \code{X} which are closest to the current point (including the current point itself unless \code{exclude=TRUE}). \item If \code{R} is given, then the neighbourhood of the current point consists of all points of \code{X} which lie closer than a distance \code{R} from the current point. \item If \code{criterion} is given, then it must be a function with two arguments \code{dist} and \code{drank} which will be vectors of equal length. The interpretation is that \code{dist[i]} will be the distance of a point from the current point, and \code{drank[i]} will be the rank of that distance (the three points closest to the current point will have rank 1, 2 and 3). This function must return a logical vector of the same length as \code{dist} and \code{drank} whose \code{i}-th entry is \code{TRUE} if the corresponding point should be included in the neighbourhood. See the examples below. \item If more than one of the arguments \code{N}, \code{R} and \code{criterion} is given, the neighbourhood is defined as the \emph{intersection} of the neighbourhoods specified by these arguments. For example if \code{N=3} and \code{R=5} then the neighbourhood is formed by finding the 3 nearest neighbours of current point, and retaining only those neighbours which lie closer than 5 units from the current point. } When \code{applynbd} is executed, each point of \code{X} is visited, and the following happens for each point: \itemize{ \item the neighbourhood of the current point is determined according to the chosen rule, and stored as a point pattern \code{Y}; \item the function \code{FUN} is called as: \code{FUN(Y=Y, current=current, dists=dists, dranks=dranks, \dots)} where \code{current} is the location of the current point (in a format explained below), \code{dists} is a vector of distances from the current point to each of the points in \code{Y}, \code{dranks} is a vector of the ranks of these distances with respect to the full point pattern \code{X}, and \code{\dots} are the arguments passed from the call to \code{applynbd}; \item The result of the call to \code{FUN} is stored. } The results of each call to \code{FUN} are collected and returned according to the usual rules for \code{\link{apply}} and its relatives. See the \bold{Value} section of this help file. The format of the argument \code{current} is as follows. If \code{X} is an unmarked point pattern, then \code{current} is a list of length 2 with entries \code{current$x} and \code{current$y} containing the coordinates of the current point. If \code{X} is marked, then \code{current} is a point pattern containing exactly one point, so that \code{current$x} is its \eqn{x}-coordinate and \code{current$marks} is its mark value. In either case, the coordinates of the current point can be referred to as \code{current$x} and \code{current$y}. Note that \code{FUN} will be called exactly as described above, with each argument named explicitly. Care is required when writing the function \code{FUN} to ensure that the arguments will match up. See the Examples. See \code{\link{markstat}} for a common use of this function. To simply tabulate the marks in every \code{R}-neighbourhood, use \code{\link[spatstat.explore]{marktable}}. } \seealso{ \code{\link{ppp.object}}, \code{\link{apply}}, \code{\link{markstat}}, \code{\link[spatstat.explore]{marktable}} } \examples{ redwood # count the number of points within radius 0.2 of each point of X nneighbours <- applynbd(redwood, R=0.2, function(Y, ...){npoints(Y)-1}) # equivalent to: nneighbours <- applynbd(redwood, R=0.2, function(Y, ...){npoints(Y)}, exclude=TRUE) # compute the distance to the second nearest neighbour of each point secondnndist <- applynbd(redwood, N = 2, function(dists, ...){max(dists)}, exclude=TRUE) # marked point pattern trees <- longleaf \testonly{ # smaller dataset trees <- trees[seq(1, npoints(trees), by=80)] } # compute the median of the marks of all neighbours of a point # (see also 'markstat') dbh.med <- applynbd(trees, R=90, exclude=TRUE, function(Y, ...) { median(marks(Y))}) # ANIMATION explaining the definition of the K function # (arguments `fullpicture' and 'rad' are passed to FUN) if(interactive()) { showoffK <- function(Y, current, dists, dranks, fullpicture,rad) { plot(fullpicture, main="") points(Y, cex=2) ux <- current[["x"]] uy <- current[["y"]] points(ux, uy, pch="+",cex=3) theta <- seq(0,2*pi,length=100) polygon(ux + rad * cos(theta), uy+rad*sin(theta)) text(ux + rad/3, uy + rad/2,npoints(Y),cex=3) if(interactive()) Sys.sleep(if(runif(1) < 0.1) 1.5 else 0.3) return(npoints(Y)) } applynbd(redwood, R=0.2, showoffK, fullpicture=redwood, rad=0.2, exclude=TRUE) # animation explaining the definition of the G function showoffG <- function(Y, current, dists, dranks, fullpicture) { plot(fullpicture, main="") points(Y, cex=2) u <- current points(u[1],u[2],pch="+",cex=3) v <- c(Y$x[1],Y$y[1]) segments(u[1],u[2],v[1],v[2],lwd=2) w <- (u + v)/2 nnd <- dists[1] text(w[1],w[2],round(nnd,3),cex=2) if(interactive()) Sys.sleep(if(runif(1) < 0.1) 1.5 else 0.3) return(nnd) } applynbd(cells, N=1, showoffG, exclude=TRUE, fullpicture=cells) } } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{programming} \keyword{iteration} spatstat.geom/man/Extract.ppp.Rd0000644000176200001440000001463714611065346016336 0ustar liggesusers\name{Extract.ppp} \alias{[.ppp} \alias{[<-.ppp} \title{Extract or Replace Subset of Point Pattern} \description{ Extract or replace a subset of a point pattern. Extraction of a subset has the effect of thinning the points and/or trimming the window. } \usage{ \method{[}{ppp}(x, i, j, drop=FALSE, \dots, clip=FALSE) \method{[}{ppp}(x, i, j) <- value } \arguments{ \item{x}{ A two-dimensional point pattern. An object of class \code{"ppp"}. } \item{i}{ Subset index. Either a valid subset index in the usual \R sense, indicating which points should be retained, or a window (an object of class \code{"owin"}) delineating a subset of the original observation window, or a pixel image with logical values defining a subset of the original observation window. } \item{value}{ Replacement value for the subset. A point pattern. } \item{j}{ Redundant. Included for backward compatibility. } \item{drop}{ Logical value indicating whether to remove unused levels of the marks, if the marks are a factor. } \item{clip}{ Logical value indicating how to form the window of the resulting point pattern, when \code{i} is a window. If \code{clip=FALSE} (the default), the result has window equal to \code{i}. If \code{clip=TRUE}, the resulting window is the intersection between the window of \code{x} and the window \code{i}. } \item{\dots}{ Ignored. This argument is required for compatibility with the generic function. } } \value{ A point pattern (of class \code{"ppp"}). } \details{ These functions extract a designated subset of a point pattern, or replace the designated subset with another point pattern. The function \code{[.ppp} is a method for \code{\link{[}} for the class \code{"ppp"}. It extracts a designated subset of a point pattern, either by ``\emph{thinning}'' (retaining/deleting some points of a point pattern) or ``\emph{trimming}'' (reducing the window of observation to a smaller subregion and retaining only those points which lie in the subregion) or both. The pattern will be ``thinned'' if \code{i} is a subset index in the usual \R sense: either a numeric vector of positive indices (identifying the points to be retained), a numeric vector of negative indices (identifying the points to be deleted) or a logical vector of length equal to the number of points in the point pattern \code{x}. In the latter case, the points \code{(x$x[i], x$y[i])} for which \code{subset[i]=TRUE} will be retained, and the others will be deleted. The pattern will be ``trimmed'' if \code{i} is an object of class \code{"owin"} specifying a window of observation. The points of \code{x} lying inside the new window \code{i} will be retained. Alternatively \code{i} may be a pixel image (object of class \code{"im"}) with logical values; the pixels with the value \code{TRUE} will be interpreted as a window. The argument \code{drop} determines whether to remove unused levels of a factor, if the point pattern is multitype (i.e. the marks are a factor) or if the marks are a data frame in which some of the columns are factors. The function \code{[<-.ppp} is a method for \code{\link{[<-}} for the class \code{"ppp"}. It replaces the designated subset with the point pattern \code{value}. The subset of \code{x} to be replaced is designated by the argument \code{i} as above. The replacement point pattern \code{value} must lie inside the window of the original pattern \code{x}. The ordering of points in \code{x} will be preserved if the replacement pattern \code{value} has the same number of points as the subset to be replaced. Otherwise the ordering is unpredictable. If the original pattern \code{x} has marks, then the replacement pattern \code{value} must also have marks, of the same type. Use the function \code{\link{unmark}} to remove marks from a marked point pattern. Use the function \code{\link{split.ppp}} to select those points in a marked point pattern which have a specified mark. } \seealso{ \code{\link{subset.ppp}}. \code{\link{ppp.object}}, \code{\link{owin.object}}, \code{\link{unmark}}, \code{\link{split.ppp}}, \code{\link{cut.ppp}} } \section{Warnings}{ The function does not check whether \code{i} is a subset of \code{Window(x)}. Nor does it check whether \code{value} lies inside \code{Window(x)}. } \examples{ # Longleaf pines data lon <- longleaf if(human <- interactive()) { plot(lon) } \testonly{lon <- lon[seq(1,npoints(lon),by=10)]} # adult trees defined to have diameter at least 30 cm longadult <- subset(lon, marks >= 30) if(human){ plot(longadult) } # note that the marks are still retained. # Use unmark(longadult) to remove the marks # New Zealand trees data if(human){ plot(nztrees) # plot shows a line of trees at the far right abline(v=148, lty=2) # cut along this line } nzw <- owin(c(0,148),c(0,95)) # the subwindow # trim dataset to this subwindow nzsub <- nztrees[nzw] if(human){ plot(nzsub) } # Redwood data if(human){ plot(redwood) } # Random thinning: delete 60\% of data retain <- (runif(npoints(redwood)) < 0.4) thinred <- redwood[retain] if(human){ plot(thinred) } # Scramble 60\% of data if(require(spatstat.random)) { X <- redwood modif <- (runif(npoints(X)) < 0.6) X[modif] <- runifpoint(ex=X[modif]) } # Lansing woods data - multitype points lan <- lansing \testonly{ lan <- lan[seq(1, npoints(lan), length=100)] } # Hickory trees hicks <- split(lansing)$hickory # Trees in subwindow win <- owin(c(0.3, 0.6),c(0.2, 0.5)) lsub <- lan[win] if(require(spatstat.random)) { # Scramble the locations of trees in subwindow, retaining their marks lan[win] <- runifpoint(ex=lsub) \%mark\% marks(lsub) } # Extract oaks only oaknames <- c("redoak", "whiteoak", "blackoak") oak <- lan[marks(lan) \%in\% oaknames, drop=TRUE] oak <- subset(lan, marks \%in\% oaknames, drop=TRUE) # To clip or not to clip X <- unmark(demopat) B <- owin(c(5500, 9000), c(2500, 7400)) opa <- par(mfrow=c(1,2)) plot(X, main="X[B]") plot(X[B], add=TRUE, cols="blue", col="pink", border="blue", show.all=TRUE, main="") plot(Window(X), add=TRUE) plot(X, main="X[B, clip=TRUE]") plot(B, add=TRUE, lty=2) plot(X[B, clip=TRUE], add=TRUE, cols="blue", col="pink", border="blue", show.all=TRUE, main="") par(opa) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/intensity.Rd0000644000176200001440000000253114611065346016142 0ustar liggesusers\name{intensity} \alias{intensity} \title{ Intensity of a Dataset or a Model } \description{ Generic function for computing the intensity of a spatial dataset or spatial point process model. } \usage{ intensity(X, ...) } \arguments{ \item{X}{ A spatial dataset or a spatial point process model. } \item{\dots}{ Further arguments depending on the class of \code{X}. } } \details{ This is a generic function for computing the intensity of a spatial dataset or spatial point process model. There are methods for point patterns (objects of class \code{"ppp"}) and fitted point process models (objects of class \code{"ppm"}). The empirical intensity of a dataset is the average density (the average amount of \sQuote{stuff} per unit area or volume). The empirical intensity of a point pattern is computed by the method \code{\link{intensity.ppp}}. The theoretical intensity of a stochastic model is the expected density (expected amount of \sQuote{stuff} per unit area or volume). The theoretical intensity of a fitted point process model is computed by the method \code{\link[spatstat.model]{intensity.ppm}}. } \value{ Usually a numeric value or vector. } \seealso{ \code{\link{intensity.ppp}}, \code{\link[spatstat.model]{intensity.ppm}}. } \author{\adrian and \rolf } \keyword{spatial} \keyword{models} spatstat.geom/man/delaunayDistance.Rd0000644000176200001440000000374214611065345017375 0ustar liggesusers\name{delaunayDistance} \alias{delaunayDistance} \title{Distance on Delaunay Triangulation} \description{ Computes the graph distance in the Delaunay triangulation of a point pattern. } \usage{ delaunayDistance(X) } \arguments{ \item{X}{Spatial point pattern (object of class \code{"ppp"}).} } \details{ The Delaunay triangulation of a spatial point pattern \code{X} is defined as follows. First the Dirichlet/Voronoi tessellation based on \code{X} is computed; see \code{\link{dirichlet}}. This tessellation is extended to cover the entire two-dimensional plane. Then two points of \code{X} are defined to be Delaunay neighbours if their Dirichlet/Voronoi tiles share a common boundary. Every pair of Delaunay neighbours is joined by a straight line to make the Delaunay triangulation. The \emph{graph distance} in the Delaunay triangulation between two points \code{X[i]} and \code{X[j]} is the minimum number of edges of the Delaunay triangulation that must be traversed to go from \code{X[i]} to \code{X[j]}. Two points have graph distance 1 if they are immediate neighbours. This command returns a matrix \code{D} such that \code{D[i,j]} is the graph distance between \code{X[i]} and \code{X[j]}. } \section{Definition of neighbours}{ Note that \code{\link{dirichlet}(X)} restricts the Dirichlet tessellation to the window containing \code{X}, whereas \code{dirichletDistance} uses the Dirichlet tessellation over the entire two-dimensional plane. Some points may be Delaunay neighbours according to \code{delaunayDistance(X)} although the corresponding tiles of \code{dirichlet(X)} do not share a boundary inside \code{Window(X)}. } \value{ A symmetric square matrix with non-negative integer entries. } \seealso{ \code{\link{delaunay}}, \code{delaunayNetwork}. } \examples{ X <- runifrect(20) M <- delaunayDistance(X) plot(delaunay(X), lty=3) text(X, labels=M[1, ], cex=2) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/areaGain.Rd0000644000176200001440000000461714611065345015631 0ustar liggesusers\name{areaGain} \alias{areaGain} \title{Difference of Disc Areas} \description{ Computes the area of that part of a disc that is not covered by other discs. } \usage{ areaGain(u, X, r, ..., W=as.owin(X), exact=FALSE, ngrid=spatstat.options("ngrid.disc")) } \arguments{ \item{u}{ Coordinates of the centre of the disc of interest. A vector of length 2. Alternatively, a point pattern (object of class \code{"ppp"}). } \item{X}{ Locations of the centres of other discs. A point pattern (object of class \code{"ppp"}). } \item{r}{ Disc radius, or vector of disc radii. } \item{\dots}{ Arguments passed to \code{\link{distmap}} to determine the pixel resolution, when \code{exact=FALSE}. } \item{W}{ Window (object of class \code{"owin"}) in which the area should be computed. } \item{exact}{ Choice of algorithm. If \code{exact=TRUE}, areas are computed exactly using analytic geometry. If \code{exact=FALSE} then a faster algorithm is used to compute a discrete approximation to the areas. } \item{ngrid}{ Integer. Number of points in the square grid used to compute the discrete approximation, when \code{exact=FALSE}. } } \value{ A matrix with one row for each point in \code{u} and one column for each value in \code{r}. } \details{ This function computes the area of that part of the disc of radius \code{r} centred at the location \code{u} that is \emph{not} covered by any of the discs of radius \code{r} centred at the points of the pattern \code{X}. This area is important in some calculations related to the area-interaction model \code{\link[spatstat.model]{AreaInter}}. If \code{u} is a point pattern and \code{r} is a vector, the result is a matrix, with one row for each point in \code{u} and one column for each entry of \code{r}. The \code{[i,j]} entry in the matrix is the area of that part of the disc of radius \code{r[j]} centred at the location \code{u[i]} that is \emph{not} covered by any of the discs of radius \code{r[j]} centred at the points of the pattern \code{X}. If \code{W} is not \code{NULL}, then the areas are computed only inside the window \code{W}. } \seealso{ \code{\link[spatstat.model]{AreaInter}}, \code{\link{areaLoss}} } \examples{ u <- c(0.5,0.5) areaGain(u, cells, 0.1) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/layout.boxes.Rd0000644000176200001440000000360414612332606016547 0ustar liggesusers\name{layout.boxes} \alias{layout.boxes} \title{ Generate a Row or Column Arrangement of Rectangles. } \description{ A simple utility to generate a row or column of boxes (rectangles) for use in point-and-click panels. } \usage{ layout.boxes(B, n, horizontal = FALSE, aspect = 0.5, usefrac = 0.9) } \arguments{ \item{B}{ Bounding rectangle for the boxes. An object of class \code{"owin"}. } \item{n}{ Integer. The number of boxes. } \item{horizontal}{ Logical. If \code{TRUE}, arrange the boxes in a horizontal row. If \code{FALSE} (the default), arrange them in a vertical column. } \item{aspect}{ A single finite positive number, giving the aspect ratio (height divided by width) of each box, or \code{NA} or \code{Inf}, indicating that the aspect ratio is unconstrained. } \item{usefrac}{ Number between 0 and 1. The fraction of height or width of \code{B} that should be occupied by boxes. } } \details{ This simple utility generates a list of boxes (rectangles) inside the bounding box \code{B} arranged in a regular row or column. It is useful for generating the positions of the panel buttons in the function \code{\link{simplepanel}}. The argument \code{aspect} specifies the ratio of height to width (height divided by width). If \code{aspect} is a finite numerical value, then the boxes will have the given aspect ratio. If \code{aspect} is \code{Inf} or \code{NA}, aspect ratio is unconstrained; the boxes will have the maximum possible width and height. } \value{ A list of rectangles (objects of class \code{"owin"} which are rectangles). } \examples{ B <- owin(c(0,10),c(0,1)) boxes <- layout.boxes(B, 5, horizontal=TRUE) plot(B, main="", col="blue") niets <- lapply(boxes, plot, add=TRUE, col="grey") } \author{ \adrian and \rolf } \seealso{ \code{\link{simplepanel}} } \keyword{utilities} spatstat.geom/man/rsyst.Rd0000644000176200001440000000502614611065350015275 0ustar liggesusers\name{rsyst} \alias{rsyst} \title{Simulate systematic random point pattern} \description{ Generates a \dQuote{systematic random} pattern of points in a window, consisting of a grid of equally-spaced points with a random common displacement. } \usage{ rsyst(win=square(1), nx=NULL, ny=nx, \dots, dx=NULL, dy=dx, nsim=1, drop=TRUE) } \arguments{ \item{win}{ A window. An object of class \code{\link{owin}}, or data in any format acceptable to \code{\link{as.owin}()}. } \item{nx}{Number of columns of grid points in the window. Incompatible with \code{dx}. } \item{ny}{Number of rows of grid points in the window. Incompatible with \code{dy}. } \item{\dots}{Ignored.} \item{dx}{Spacing of grid points in \eqn{x} direction. Incompatible with \code{nx}. } \item{dy}{Spacing of grid points in \eqn{y} direction. Incompatible with \code{ny}. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1}, or a list of point patterns if \code{nsim > 1}. } \details{ This function generates a \dQuote{systematic random} pattern of points in the window \code{win}. The pattern consists of a rectangular grid of points with a random common displacement. The grid spacing in the \eqn{x} direction is determined either by the number of columns \code{nx} or by the horizontal spacing \code{dx}. The grid spacing in the \eqn{y} direction is determined either by the number of rows \code{ny} or by the vertical spacing \code{dy}. The grid is then given a random displacement (the common displacement of the grid points is a uniformly distributed random vector in the tile of dimensions \code{dx, dy}). Some of the resulting grid points may lie outside the window \code{win}: if they do, they are deleted. The result is a point pattern inside the window \code{win}. This function is useful in creating dummy points for quadrature schemes (see \code{\link{quadscheme}}) as well as in simulating random point patterns. } \seealso{ \code{\link[spatstat.random]{rstrat}}, \code{\link[spatstat.random]{runifpoint}}, \code{\link{quadscheme}} } \examples{ X <- rsyst(nx=10) plot(X) # polygonal boundary X <- rsyst(letterR, 5, 10) plot(X) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/as.tess.Rd0000644000176200001440000000502214650323103015461 0ustar liggesusers\name{as.tess} \alias{as.tess} \alias{as.tess.tess} \alias{as.tess.im} \alias{as.tess.owin} \alias{as.tess.quadratcount} \alias{as.tess.list} \title{Convert Data To Tessellation} \description{ Converts data specifying a tessellation, in any of several formats, into an object of class \code{"tess"}. } \usage{ as.tess(X) \method{as.tess}{tess}(X) \method{as.tess}{im}(X) \method{as.tess}{owin}(X) \method{as.tess}{quadratcount}(X) \method{as.tess}{list}(X) } \arguments{ \item{X}{Data to be converted to a tessellation.} } \value{ An object of class \code{"tess"} specifying a tessellation. } \details{ A tessellation is a collection of disjoint spatial regions (called \emph{tiles}) that fit together to form a larger spatial region. This command creates an object of class \code{"tess"} that represents a tessellation. This function converts data in any of several formats into an object of class \code{"tess"} for use by the \pkg{spatstat} package. The argument \code{X} may be \itemize{ \item an object of class \code{"tess"}. The object will be stripped of any extraneous attributes and returned. \item a pixel image (object of class \code{"im"}) with pixel values that are logical or factor values. Each level of the factor will determine a tile of the tessellation. \item a window (object of class \code{"owin"}). The result will be a tessellation consisting of a single tile. \item a set of quadrat counts (object of class \code{"quadratcount"}) returned by the command \code{\link[spatstat.geom]{quadratcount}}. The quadrats used to generate the counts will be extracted and returned as a tessellation. \item a quadrat test (object of class \code{"quadrattest"}) returned by the command \code{\link[spatstat.explore]{quadrat.test}}. The quadrats used to perform the test will be extracted and returned as a tessellation. \item a list of windows (objects of class \code{"owin"}) giving the tiles of the tessellation. } The function \code{as.tess} is generic, with methods for various classes, as listed above. } \seealso{ \code{\link[spatstat.geom]{tess}} \code{\link[spatstat.geom]{quadratcount}} } \examples{ # pixel image v <- as.im(function(x,y){factor(round(5 * (x^2 + y^2)))}, W=owin()) levels(v) <- letters[seq(length(levels(v)))] as.tess(v) # quadrat counts qNZ <- quadratcount(nztrees, nx=4, ny=3) as.tess(qNZ) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} \concept{Tessellation} spatstat.geom/man/is.ppp.Rd0000644000176200001440000000130614611065347015325 0ustar liggesusers\name{is.ppp} \alias{is.ppp} \title{Test Whether An Object Is A Point Pattern} \description{ Checks whether its argument is a point pattern (object of class \code{"ppp"}). } \usage{ is.ppp(x) } \arguments{ \item{x}{Any object.} } \details{ This function tests whether the object \code{x} is a point pattern object of class \code{"ppp"}. See \code{\link{ppp.object}} for details of this class. The result is determined to be \code{TRUE} if \code{x} inherits from \code{"ppp"}, i.e. if \code{x} has \code{"ppp"} amongst its classes. } \value{ \code{TRUE} if \code{x} is a point pattern, otherwise \code{FALSE}. } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/plot.im.Rd0000644000176200001440000005030714723232636015504 0ustar liggesusers\name{plot.im} \alias{plot.im} \alias{image.im} \title{Plot a Pixel Image} \description{ Plot a pixel image. } \usage{ \method{plot}{im}(x, \dots, main, add=FALSE, clipwin=NULL, col=NULL, reverse.col=FALSE, valuesAreColours=NULL, log=FALSE, ncolours=256, gamma=1, ribbon=show.all, show.all=!add, drop.ribbon=FALSE, ribside=c("right", "left", "bottom", "top"), ribsep=0.15, ribwid=0.05, ribn=1024, ribscale=1, ribargs=list(), riblab=NULL, colargs=list(), useRaster=NULL, workaround=FALSE, zap=1, do.plot=TRUE, addcontour=FALSE, contourargs=list()) \method{image}{im}(x, \dots, main, add=FALSE, clipwin=NULL, col=NULL, reverse.col=FALSE, valuesAreColours=NULL, log=FALSE, ncolours=256, gamma=1, ribbon=show.all, show.all=!add, drop.ribbon=FALSE, ribside=c("right", "left", "bottom", "top"), ribsep=0.15, ribwid=0.05, ribn=1024, ribscale=1, ribargs=list(), riblab=NULL, colargs=list(), useRaster=NULL, workaround=FALSE, zap=1, do.plot=TRUE, addcontour=FALSE, contourargs=list()) } \arguments{ \item{x}{ The pixel image to be plotted. An object of class \code{"im"} (see \code{\link{im.object}}). } \item{\dots}{ Extra arguments passed to \code{\link[graphics]{image.default}} to control the plot. See Details. } \item{main}{Main title for the plot.} \item{add}{ Logical value indicating whether to superimpose the image on the existing plot (\code{add=TRUE}) or to initialise a new plot (\code{add=FALSE}, the default). } \item{clipwin}{ Optional. A window (object of class \code{"owin"}). Only this subset of the image will be displayed. } \item{col}{ Colours for displaying the pixel values. Either a character vector of colour values, an object of class \code{\link{colourmap}}, or a \code{function} as described under Details. } \item{reverse.col}{ Logical value. If \code{TRUE}, the sequence of colour values specified by \code{col} will be reversed. } \item{valuesAreColours}{ Logical value. If \code{TRUE}, the pixel values of \code{x} are to be interpreted as colour values. } \item{log}{ Logical value. If \code{TRUE}, the colour map will be evenly-spaced on a logarithmic scale. } \item{ncolours}{ Integer. The default number of colours in the colour map for a real-valued image. } \item{gamma}{ Exponent for the gamma correction of the colours. A single positive number. } \item{ribbon}{ Logical flag indicating whether to display a ribbon showing the colour map. Default is \code{TRUE} for new plots and \code{FALSE} for added plots. } \item{show.all}{ Logical value indicating whether to display all plot elements including the main title and colour ribbon. Default is \code{TRUE} for new plots and \code{FALSE} for added plots. } \item{drop.ribbon}{ Logical value. If \code{TRUE}, then a ribbon will not be displayed if all pixel values are equal. } \item{ribside}{ Character string indicating where to display the ribbon relative to the main image. } \item{ribsep}{ Factor controlling the space between the ribbon and the image. } \item{ribwid}{ Factor controlling the width of the ribbon. } \item{ribn}{ Number of different values to display in the ribbon. } \item{ribscale}{ Rescaling factor for tick marks. The values on the numerical scale printed beside the ribbon will be multiplied by this rescaling factor. } \item{ribargs}{ List of additional arguments passed to \code{\link[graphics]{image.default}}, \code{\link[graphics]{axis}} and \code{\link[grDevices]{axisTicks}} to control the display of the ribbon and its scale axis. These may override the \code{\dots} arguments. } \item{riblab}{ Text to be plotted in the margin near the ribbon. A character string or expression to be interpreted as text, or a list of arguments to be passed to \code{\link[graphics]{mtext}}. } \item{colargs}{ List of additional arguments passed to \code{col} if it is a function. } \item{useRaster}{ Logical value, passed to \code{\link[graphics]{image.default}}. Images are plotted using a bitmap raster if \code{useRaster=TRUE} or by drawing polygons if \code{useRaster=FALSE}. Bitmap raster display tends to produce better results, but is not supported on all graphics devices. The default is to use bitmap raster display if it is supported. } \item{workaround}{ Logical value, specifying whether to use a workaround to avoid a bug which occurs with some device drivers in \R, in which the image has the wrong spatial orientation. See the section on \bold{Image is Displayed in Wrong Spatial Orientation} below. } \item{zap}{ Noise threshold factor. A numerical value greater than or equal to 1. If the range of pixel values is less than \code{zap * .Machine$double.eps}, the image will be treated as constant. This avoids displaying images which should be constant but contain small numerical errors. } \item{do.plot}{ Logical value indicating whether to actually plot the image and colour ribbon. Setting \code{do.plot=FALSE} will simply return the colour map and the bounding box that were chosen for the plot. } \item{addcontour}{ Logical value specifying whether to add contour lines to the image plot. The contour lines will also be drawn on the colour ribbon. } \item{contourargs}{ Optional list of arguments to be passed to \code{\link[graphics]{contour.default}} to control the contour plot. } } \value{ The colour map used. An object of class \code{"colourmap"}. Also has an attribute \code{"bbox"} giving a bounding box for the plot (containing the main colour image and the colour ribbon if plotted). If a ribbon was plotted, there is also an attribute \code{"bbox.legend"} giving a bounding box for the ribbon image. Text annotation occurs outside these bounding boxes. } \details{ This is the \code{plot} method for the class \code{"im"}. [It is also the \code{image} method for \code{"im"}.] The pixel image \code{x} is displayed on the current plot device, using equal scales on the \code{x} and \code{y} axes. If \code{ribbon=TRUE}, a legend will be plotted. The legend consists of a colour ribbon and an axis with tick-marks, showing the correspondence between the pixel values and the colour map. Arguments \code{ribside, ribsep, ribwid} control the placement of the colour ribbon. By default, the ribbon is placed at the right of the main image. This can be changed using the argument \code{ribside}. The width of the ribbon is \code{ribwid} times the size of the pixel image, where `size' means the larger of the width and the height. The distance separating the ribbon and the image is \code{ribsep} times the size of the pixel image. The ribbon contains the colours representing \code{ribn} different numerical values, evenly spaced between the minimum and maximum pixel values in the image \code{x}, rendered according to the chosen colour map. The argument \code{ribargs} controls the annotation of the colour ribbon. It is a list of arguments to be passed to \code{\link[graphics]{image.default}}, \code{\link[graphics]{axis}} and \code{\link[grDevices]{axisTicks}}. To plot the colour ribbon without the axis and tick-marks, use \code{ribargs=list(axes=FALSE)}. To ensure that the numerals or symbols printed next to the colour map are oriented horizontally, use \code{ribargs=list(las=1)}. To double the size of the numerals or symbols, use \code{ribargs=list(cex.axis=2)}. To control the number of tick-marks, use \code{ribargs=list(nint=N)} where \code{N} is the desired number of intervals (so there will be \code{N+1} tickmarks, subject to the vagaries of \R internal code). The argument \code{riblab} contains text that will be displayed in the margin next to the ribbon. The argument \code{ribscale} is used to rescale the numerical values printed next to the colour map, for convenience. For example if the pixel values in \code{x} range between 1000 and 4000, it would be sensible to use \code{ribscale=1/1000} so that the colour map tickmarks would be labelled 1 to 4. Normally the pixel values are displayed using the colours given in the argument \code{col}. This may be either \itemize{ \item an explicit colour map (an object of class \code{"colourmap"}, created by the command \code{\link{colourmap}}). This is the best way to ensure that when we plot different images, the colour maps are consistent. \item a character vector or integer vector that specifies a set of colours. The colour mapping will be stretched to match the range of pixel values in the image \code{x}. The mapping of pixel values to colours is determined as follows. \describe{ \item{logical-valued images:}{the values \code{FALSE} and \code{TRUE} are mapped to the colours \code{col[1]} and \code{col[2]} respectively. The vector \code{col} should have length 2. } \item{factor-valued images:}{the factor levels \code{levels(x)} are mapped to the entries of \code{col} in order. The vector \code{col} should have the same length as \code{levels(x)}. } \item{numeric-valued images:}{ By default, the range of pixel values in \code{x} is divided into \code{n = length(col)} equal subintervals, which are mapped to the colours in \code{col}. (If \code{col} was not specified, it defaults to a vector of 255 colours.) Alternatively if the argument \code{zlim} is given, it should be a vector of length 2 specifying an interval of real numbers. This interval will be used instead of the range of pixel values. The interval from \code{zlim[1]} to \code{zlim[2]} will be mapped to the colours in \code{col}. This facility enables the user to plot several images using a consistent colour map. Alternatively if the argument \code{breaks} is given, then this specifies the endpoints of the subintervals that are mapped to each colour. This is incompatible with \code{zlim}. The arguments \code{col} and \code{zlim} or \code{breaks} are then passed to the function \code{\link{image.default}}. For examples of the use of these arguments, see \code{\link{image.default}}. } } \item { a \code{function} in the \R language with an argument named \code{range} or \code{inputs}. If \code{col} is a function with an argument named \code{range}, and if the pixel values of \code{x} are numeric values, then the colour values will be determined by evaluating \code{col(range=range(x))}. The result of this evaluation should be a character vector containing colour values, or a \code{"colourmap"} object. Examples of such functions are \code{\link{beachcolours}} and \code{\link{beachcolourmap}}. If \code{col} is a function with an argument named \code{inputs}, and if the pixel values of \code{x} are discrete values (integer, logical, factor or character), then the colour values will be determined by evaluating \code{col(inputs=p)} where \code{p} is the set of possible pixel values. The result should be a character vector containing colour values, or a \code{"colourmap"} object. } \item{ a \code{function} in the \R language with first argument named \code{n}. The colour values will be determined by evaluating \code{col(n)} where \code{n} is the number of distinct pixel values, up to a maximum of 128. The result of this evaluation should be a character vector containing color values. Examples of such functions are \code{\link[grDevices]{heat.colors}}, \code{\link[grDevices]{terrain.colors}}, \code{\link[grDevices]{topo.colors}} and \code{\link[grDevices]{cm.colors}}. } } If \code{col} is missing or \code{col=NULL}, the default colour values are the linear, perceptually uniform colour sequence given by \code{\link[spatstat.data]{Kovesi}[[29,"values"]]}. If \code{spatstat.options("monochrome")} has been set to \code{TRUE} then \bold{all colours will be converted to grey scale values}. If \code{reverse.col=TRUE}, the sequence of colour values specified by \code{col} will be reversed (unless \code{valuesAreColours=TRUE}). Other graphical parameters controlling the display of both the pixel image and the ribbon can be passed through the \code{...} arguments to the function \code{\link[graphics]{image.default}}. A parameter is handled only if it is one of the following: \itemize{ \item a formal argument of \code{\link[graphics]{image.default}} that is operative when \code{add=TRUE}. \item one of the parameters \code{"main", "asp", "sub", "axes", "xlab", "ylab"} described in \code{\link[graphics]{plot.default}}. \item one of the parameters \code{"ann", "cex", "font", "cex.axis", "cex.lab", "cex.main", "cex.sub", "col.axis", "col.lab", "col.main", "col.sub", "font.axis", "font.lab", "font.main", "font.sub"} described in \code{\link[graphics]{par}}. \item the argument \code{box}, a logical value specifying whether a box should be drawn. } Images are plotted using a bitmap raster if \code{useRaster=TRUE} or by drawing polygons if \code{useRaster=FALSE}. Bitmap raster display (performed by \code{\link[graphics]{rasterImage}}) tends to produce better results, but is not supported on all graphics devices. The default is to use bitmap raster display if it is supported according to \code{\link[grDevices]{dev.capabilities}}. Alternatively, the pixel values could be directly interpretable as colour values in \R. That is, the pixel values could be character strings that represent colours, or values of a factor whose levels are character strings representing colours. \itemize{ \item If \code{valuesAreColours=TRUE}, then the pixel values will be interpreted as colour values and displayed using these colours. \item If \code{valuesAreColours=FALSE}, then the pixel values will \emph{not} be interpreted as colour values, even if they could be. \item If \code{valuesAreColours=NULL}, the algorithm will guess what it should do. If the argument \code{col} is given, the pixel values will \emph{not} be interpreted as colour values. Otherwise, if all the pixel values are strings that represent colours, then they will be interpreted and displayed as colours. } If pixel values are interpreted as colours, the arguments \code{col} and \code{ribbon} will be ignored, and a ribbon will not be plotted. } \section{Adding contour lines}{ If \code{addcontour=TRUE}, contour lines will be superimposed on the image. Lines will also be superimposed on the colour ribbon at the corresponding positions. The display of the contour lines can be controlled by arguments specified in \code{contourargs}. } \section{Main title, box and white space}{ The left-right placement of the main title is controlled by the argument \code{adj.main} passed to \code{\link[spatstat.geom]{plot.owin}}. A rectangular box surrounding the image domain is drawn by default; it can be suppressed by setting \code{box=FALSE}. White space around the plot is controlled by \code{\link[graphics]{par}('mar')}. } \section{Complex-valued images}{ If the pixel values in \code{x} are complex numbers, they will be converted into four images containing the real and imaginary parts and the modulus and argument, and plotted side-by-side using \code{\link{plot.imlist}}. } \section{Monochrome colours}{ If \code{spatstat.options("monochrome")} has been set to \code{TRUE}, then \bold{the image will be plotted in greyscale}. The colours are converted to grey scale values using \code{\link{to.grey}}. The choice of colour map still has an effect, since it determines the final grey scale values. Monochrome display can also be achieved by setting the graphics device parameter \code{colormodel="grey"} when starting a new graphics device, or in a call to \code{\link{ps.options}} or \code{\link{pdf.options}}. } \section{Image Looks Like Noise}{ An image plot which looks like digital noise can be produced when the pixel values are almost exactly equal but include a tiny amount of numerical error. To check this, look at the numerals plotted next to the colour ribbon, or compute \code{diff(range(x))}, to determine whether the range of pixel values is almost zero. The behaviour can be suppressed by picking a larger value of the argument \code{zap}. } \section{Image Rendering Errors and Problems}{ The help for \code{\link[graphics]{image.default}} and \code{\link[graphics]{rasterImage}} explains that errors may occur, or images may be rendered incorrectly, on some devices, depending on the availability of colours and other device-specific constraints. If the image is not displayed at all, try setting \code{useRaster=FALSE} in the call to \code{plot.im}. If the ribbon colours are not displayed, set \code{ribargs=list(useRaster=FALSE)}. Errors may occur on some graphics devices if the image is very large. If this happens, try setting \code{useRaster=FALSE} in the call to \code{plot.im}. The error message \code{useRaster=TRUE can only be used with a regular grid} means that the \eqn{x} and \eqn{y} coordinates of the pixels in the image are not perfectly equally spaced, due to numerical rounding. This occurs with some images created by earlier versions of \pkg{spatstat}. To repair the coordinates in an image \code{X}, type \code{X <- as.im(X)}. } \section{Image is Displayed in Wrong Spatial Orientation}{ If the image is displayed in the wrong spatial orientation, and you created the image data directly, please check that you understand the \pkg{spatstat} convention for the spatial orientation of pixel images. The row index of the matrix of pixel values corresponds to the increasing \eqn{y} coordinate; the column index of the matrix corresponds to the increasing \eqn{x} coordinate (Baddeley, Rubak and Turner, 2015, section 3.6.3, pages 66--67). Images can be displayed in the wrong spatial orientation on some devices, due to a bug in the device driver. This occurs only when the plot coordinates are \emph{reversed}, that is, when the plot was initialised with coordinate limits \code{xlim, ylim} such that \code{xlim[1] > xlim[2]} or \code{ylim[1] > ylim[2]} or both. This bug is reported to occur only when \code{useRaster=TRUE}. To fix this, try setting \code{workaround=TRUE}, or if that is unsuccessful, \code{useRaster=FALSE}. } \seealso{ \code{\link{im.object}}, \code{\link{colourmap}}, \code{\link{contour.im}}, \code{\link{persp.im}}, \code{\link{hist.im}}, \code{\link[graphics]{image.default}}, \code{\link{spatstat.options}}, \code{\link{default.image.colours}} } \examples{ # an image Z <- setcov(owin()) plot(Z) plot(Z, ribside="bottom") # stretchable colour map plot(Z, col=rainbow) plot(Z, col=terrain.colors(128), axes=FALSE) # fixed colour map tc <- colourmap(rainbow(128), breaks=seq(-1,2,length=129)) plot(Z, col=tc) # colour map function, with argument 'range' plot(Z, col=beachcolours, colargs=list(sealevel=0.5)) # tweaking the plot plot(Z, main="La vie en bleu", col.main="blue", cex.main=1.5, box=FALSE, ribargs=list(col.axis="blue", col.ticks="blue", cex.axis=0.75)) # add axes and axis labels plot(Z, axes=TRUE, ann=TRUE, xlab="Easting", ylab="Northing") # add contour lines plot(Z, addcontour=TRUE, contourargs=list(col="white", drawlabels=FALSE)) # log scale V <- eval.im(exp(exp(Z+2))/1e4) plot(V, log=TRUE, main="Log scale") # it's complex Y <- exp(Z + V * 1i) plot(Y) } \references{ \baddrubaturnbook } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/spatdim.Rd0000644000176200001440000000304514611065350015551 0ustar liggesusers\name{spatdim} \alias{spatdim} \title{Spatial Dimension of a Dataset} \description{ Extracts the spatial dimension of an object in the \pkg{spatstat} package. } \usage{spatdim(X, intrinsic=FALSE)} \arguments{ \item{X}{ Object belonging to any class defined in the \pkg{spatstat} package. } \item{intrinsic}{ Logical value indicating whether to return the number of intrinsic dimensions. See Details. } } \value{ An integer, or \code{NA}. } \details{ This function returns the number of spatial coordinate dimensions of the dataset \code{X}. The results for some of the more common types of objects are as follows: \tabular{ll}{ \bold{object class} \tab \bold{dimension} \cr \code{"ppp"} \tab 2 \cr \code{"lpp"} \tab 2 \cr \code{"pp3"} \tab 3 \cr \code{"ppx"} \tab number of \emph{spatial} dimensions \cr \code{"owin"} \tab 2 \cr \code{"psp"} \tab 2 \cr \code{"ppm"} \tab 2 } Note that time dimensions are not counted. Some spatial objects are lower-dimensional subsets of the space in which they live. This lower number of dimensions is returned if \code{intrinsic=TRUE}. For example, a dataset on a linear network (an object \code{X} of class \code{"linnet", "lpp", "linim", "linfun"} or \code{"lintess"}) returns \code{spatdim(X) = 2} but \code{spatdim(X, intrinsic=TRUE) = 1}. If \code{X} is not a recognised spatial object, the result is \code{NA}. } \author{ \spatstatAuthors. } \examples{ spatdim(lansing) A <- osteo$pts[[1]] spatdim(A) spatdim(domain(A)) } spatstat.geom/man/pairdist.psp.Rd0000644000176200001440000000527214742317360016542 0ustar liggesusers\name{pairdist.psp} \alias{pairdist.psp} \title{Pairwise distances between line segments} \description{ Computes the matrix of distances between all pairs of line segments in a line segment pattern. } \usage{ \method{pairdist}{psp}(X, \dots, method="C", type="Hausdorff") } \arguments{ \item{X}{ A line segment pattern (object of class \code{"psp"}). } \item{\dots}{ Ignored. } \item{method}{ String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. Usually not specified. } \item{type}{ Type of distance to be computed. Options are \code{"Hausdorff"} and \code{"separation"}. Partial matching is used. } } \value{ A square matrix whose \code{[i,j]} entry is the distance between the line segments numbered \code{i} and \code{j}. } \details{ This function computes the distance between each pair of line segments in \code{X}, and returns the matrix of distances. This is a method for the generic function \code{\link{pairdist}} for the class \code{"psp"}. The distances between line segments are measured in one of two ways: \itemize{ \item if \code{type="Hausdorff"}, distances are computed in the Hausdorff metric. The Hausdorff distance between two line segments is the \emph{maximum} distance from any point on one of the segments to the nearest point on the other segment. \item if \code{type="separation"}, distances are computed as the \emph{minimum} distance from a point on one line segment to a point on the other line segment. For example, line segments which cross over each other have separation zero. } The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted \R code only. If \code{method="C"} (the default) then compiled \code{C} code is used, which is somewhat faster. } \section{Distance values}{ The values returned by \code{pairdist(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{pairdist(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{crossdist}}, \code{\link{nndist}}, \code{\link{pairdist.ppp}} } \examples{ L <- psp(runif(10), runif(10), runif(10), runif(10), owin()) D <- pairdist(L) S <- pairdist(L, type="sep") } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/edges2vees.Rd0000644000176200001440000000303714611065346016152 0ustar liggesusers\name{edges2vees} \alias{edges2vees} \title{ List Dihedral Triples in a Graph } \description{ Given a list of edges between vertices, compile a list of all \sQuote{vees} or dihedral triples formed by these edges. } \usage{ edges2vees(iedge, jedge, nvert=max(iedge, jedge), \dots, check=TRUE) } \arguments{ \item{iedge,jedge}{ Integer vectors, of equal length, specifying the edges. } \item{nvert}{ Number of vertices in the network. } \item{\dots}{Ignored} \item{check}{Logical. Whether to check validity of input data.} } \details{ Given a finite graph with \code{nvert} vertices and with edges specified by \code{iedge, jedge}, this low-level function finds all \sQuote{vees} or \sQuote{dihedral triples} in the graph, that is, all triples of vertices \code{(i,j,k)} where \code{i} and \code{j} are joined by an edge and \code{i} and \code{k} are joined by an edge. The interpretation of \code{iedge, jedge} is that each successive pair of entries specifies an edge in the graph. The \eqn{k}th edge joins vertex \code{iedge[k]} to vertex \code{jedge[k]}. Entries of \code{iedge} and \code{jedge} must be integers from 1 to \code{nvert}. } \value{ A 3-column matrix of integers, in which each row represents a triple of vertices, with the first vertex joined to the other two vertices. } \seealso{ \code{\link{edges2triangles}} } \author{\adrian and \rolf } \examples{ i <- c(1, 2, 5, 5, 1, 4, 2) j <- c(2, 3, 3, 1, 3, 2, 5) edges2vees(i, j) } \keyword{spatial} \keyword{manip} spatstat.geom/man/nsegments.Rd0000644000176200001440000000133114611065347016115 0ustar liggesusers\name{nsegments} \alias{nsegments} \alias{nsegments.psp} \title{ Number of Line Segments in a Line Segment Pattern } \description{ Returns the number of line segments in a line segment pattern. } \usage{ nsegments(x) \method{nsegments}{psp}(x) } \arguments{ \item{x}{ A line segment pattern, i.e. an object of class \code{psp}, or an object containing a linear network. } } \details{ This function is generic, with methods for classes \code{psp}, \code{linnet} and \code{lpp}. } \value{ Integer. } \author{ \spatstatAuthors } \seealso{ \code{\link{npoints}()}, \code{\link{psp.object}()} } \examples{ nsegments(copper$Lines) nsegments(copper$SouthLines) } \keyword{spatial} \keyword{manip} spatstat.geom/man/methods.boxx.Rd0000644000176200001440000000363614611065347016546 0ustar liggesusers\name{methods.boxx} \Rdversion{1.1} \alias{methods.boxx} %DoNotExport \alias{print.boxx} \alias{unitname.boxx} \alias{unitname<-.boxx} \alias{scale.boxx} \title{ Methods for Multi-Dimensional Box } \description{ Methods for class \code{"boxx"}. } \usage{ \method{print}{boxx}(x, ...) \method{unitname}{boxx}(x) \method{unitname}{boxx}(x) <- value \method{scale}{boxx}(x, center=TRUE, scale=TRUE) } \arguments{ \item{x}{ Object of class \code{"boxx"} representing a multi-dimensional box. } \item{\dots}{ Other arguments passed to \code{print.default}. } \item{value}{ Name of the unit of length. See \code{\link{unitname}}. } \item{center,scale}{ Arguments passed to \code{\link[base]{scale.default}} to determine the rescaling. } } \details{ These are methods for the generic functions \code{\link{print}}, \code{\link{unitname}}, \code{\link{unitname<-}} and \code{\link[base]{scale}} for the class \code{"boxx"} of multi-dimensional boxes. The \code{print} method prints a description of the box, the \code{unitname} method extracts the name of the unit of length in which the box coordinates are expressed, while the assignment method for \code{unitname} assigns this unit name. The \code{scale} method rescales each spatial coordinate of \code{x}. } \value{ For \code{print.boxx} the value is \code{NULL}. For \code{unitname.boxx} an object of class \code{"units"}. For \code{unitname<-.boxx} and \code{scale.boxx} the result is the updated \code{"boxx"} object \code{x}. } \author{ \spatstatAuthors } \seealso{ \code{\link{boxx}}, \code{\link{is.boxx}}, \code{\link{print}}, \code{\link{unitname}}, \code{\link[base]{scale}} } \examples{ B <- boxx(c(0,10),c(0,10),c(0,5),c(0,1), unitname=c("metre", "metres")) B is.boxx(B) unitname(B) # Northern European usage unitname(B) <- "meter" scale(B) } \keyword{spatial} \keyword{methods} spatstat.geom/man/shift.psp.Rd0000644000176200001440000000474114611065350016032 0ustar liggesusers\name{shift.psp} \alias{shift.psp} \title{Apply Vector Translation To Line Segment Pattern} \description{ Applies a vector shift to a line segment pattern. } \usage{ \method{shift}{psp}(X, vec=c(0,0), \dots, origin=NULL) } \arguments{ \item{X}{Line Segment pattern (object of class \code{"psp"}).} \item{vec}{Vector of length 2 representing a translation.} \item{\dots}{Ignored} \item{origin}{ Location that will be shifted to the origin. Either a numeric vector of length 2 giving the location, or a point pattern containing only one point, or a list with two entries named \code{x} and \code{y}, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). } } \value{ Another line segment pattern (of class \code{"psp"}) representing the result of applying the vector shift. } \details{ The line segment pattern, and its window, are translated by the vector \code{vec}. This is a method for the generic function \code{\link{shift}}. If \code{origin} is given, the argument \code{vec} will be ignored; instead the shift will be performed so that the specified geometric location is shifted to the coordinate origin \eqn{(0,0)}. The argument \code{origin} should be either a numeric vector of length 2 giving the spatial coordinates of a location, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). If \code{origin="centroid"} then the centroid of the window will be shifted to the origin. If \code{origin="midpoint"} then the centre of the bounding rectangle of the window will be shifted to the origin. If \code{origin="bottomleft"} then the bottom left corner of the bounding rectangle of the window will be shifted to the origin, and so on. } \seealso{ \code{\link{shift}}, \code{\link{shift.owin}}, \code{\link{shift.ppp}}, \code{\link{periodify}}, \code{\link{rotate}}, \code{\link{affine}} } \examples{ X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) plot(X, col="red") Y <- shift(X, c(0.05,0.05)) plot(Y, add=TRUE, col="blue") shift(Y, origin="mid") } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/convexhull.Rd0000644000176200001440000000150214611065345016277 0ustar liggesusers\name{convexhull} \alias{convexhull} \title{Convex Hull} \description{ Computes the convex hull of a spatial object. } \usage{ convexhull(x) } \arguments{ \item{x}{ a window (object of class \code{"owin"}), a point pattern (object of class \code{"ppp"}), a line segment pattern (object of class \code{"psp"}), or an object that can be converted to a window by \code{\link{as.owin}}. } } \value{ A window (an object of class \code{"owin"}). } \details{ This function computes the convex hull of the spatial object \code{x}. } \seealso{ \code{\link{owin}}, \code{\link{convexhull.xy}}, \code{\link{is.convex}} } \examples{ W <- Window(demopat) plot(convexhull(W), col="lightblue", border=NA) plot(W, add=TRUE, lwd=2) } \author{\adrian and \rolf } \keyword{spatial} \keyword{utilities} spatstat.geom/man/Extract.ppx.Rd0000644000176200001440000000517714611065346016345 0ustar liggesusers\name{Extract.ppx} \alias{[.ppx} \title{Extract Subset of Multidimensional Point Pattern} \description{ Extract a subset of a multidimensional point pattern. } \usage{ \method{[}{ppx}(x, i, drop=FALSE, clip=FALSE, ...) } \arguments{ \item{x}{ A multidimensional point pattern (object of class \code{"ppx"}). } \item{i}{ Subset index. A valid subset index in the usual \R sense, indicating which points should be retained; or a spatial domain of class \code{"boxx"} or \code{"box3"}. } \item{drop}{ Logical value indicating whether to remove unused levels of the marks, if the marks are a factor. } \item{clip}{ Logical value indicating how to form the domain of the resulting point pattern, when \code{i} is a box (object of class \code{"boxx"}). If \code{clip=FALSE} (the default), the result has domain equal to \code{i}. If \code{clip=TRUE}, the resulting domain is the intersection between the domain of \code{x} and the domain \code{i}. } \item{\dots}{ Ignored. } } \value{ A multidimensional point pattern (of class \code{"ppx"}). } \details{ This function extracts a designated subset of a multidimensional point pattern. The function \code{[.ppx} is a method for \code{\link{[}} for the class \code{"ppx"}. It extracts a designated subset of a point pattern. The argument \code{i} may be either \itemize{ \item a subset index in the usual \R sense: either a numeric vector of positive indices (identifying the points to be retained), a numeric vector of negative indices (identifying the points to be deleted) or a logical vector of length equal to the number of points in the point pattern \code{x}. In the latter case, the points \code{(x$x[i], x$y[i])} for which \code{subset[i]=TRUE} will be retained, and the others will be deleted. \item a spatial domain of class \code{"boxx"} or \code{"box3"}. Points falling inside this region will be retained. } The argument \code{drop} determines whether to remove unused levels of a factor, if the point pattern is multitype (i.e. the marks are a factor) or if the marks are a data frame or hyperframe in which some of the columns are factors. Use the function \code{\link{unmark}} to remove marks from a marked point pattern. } \seealso{ \code{\link{ppx}} } \examples{ df <- data.frame(x=runif(4),y=runif(4),z=runif(4)) X <- ppx(data=df, coord.type=c("s","s","t")) X[-2] Y <- ppx(coords(cells), domain = boxx(c(0,1),c(0,1))) dom <- shift(domain(Y), vec = c(.5,.5)) Y[dom] Y[dom, clip=TRUE] } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/opening.Rd0000644000176200001440000000471114643111575015556 0ustar liggesusers\name{opening} \alias{opening} \alias{opening.owin} \alias{opening.psp} \alias{opening.ppp} \title{Morphological Opening} \description{ Perform morphological opening of a window, a line segment pattern or a point pattern. } \usage{ opening(w, r, \dots) \method{opening}{owin}(w, r, \dots, polygonal=NULL) \method{opening}{ppp}(w, r, \dots) \method{opening}{psp}(w, r, \dots) } \arguments{ \item{w}{ A window (object of class \code{"owin"} or a line segment pattern (object of class \code{"psp"}) or a point pattern (object of class \code{"ppp"}). } \item{r}{positive number: the radius of the opening.} \item{\dots}{ extra arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution, if a pixel approximation is used } \item{polygonal}{ Logical flag indicating whether to compute a polygonal approximation to the erosion (\code{polygonal=TRUE}) or a pixel grid approximation (\code{polygonal=FALSE}). } } \value{ If \code{r > 0}, an object of class \code{"owin"} representing the opened region. If \code{r=0}, the result is identical to \code{w}. } \details{ The morphological opening (Serra, 1982) of a set \eqn{W} by a distance \eqn{r > 0} is the subset of points in \eqn{W} that can be separated from the boundary of \eqn{W} by a circle of radius \eqn{r}. That is, a point \eqn{x} belongs to the opening if it is possible to draw a circle of radius \eqn{r} (not necessarily centred on \eqn{x}) that has \eqn{x} on the inside and the boundary of \eqn{W} on the outside. The opened set is a subset of \code{W}. For a small radius \eqn{r}, the opening operation has the effect of smoothing out irregularities in the boundary of \eqn{W}. For larger radii, the opening operation removes promontories in the boundary. For very large radii, the opened set is empty. The algorithm applies \code{\link{erosion}} followed by \code{\link{dilation}}. } \seealso{ \code{\link{closing}} for the opposite operation. \code{\link{dilation}}, \code{\link{erosion}} for the basic operations. \code{\link{owin}}, \code{\link{as.owin}} for information about windows. } \examples{ v <- opening(letterR, 0.3) plot(letterR, type="n", main="opening") plot(v, add=TRUE, col="grey") plot(letterR, add=TRUE) } \references{ Serra, J. (1982) Image analysis and mathematical morphology. Academic Press. } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/pppmatching.Rd0000644000176200001440000000467514611065350016434 0ustar liggesusers\name{pppmatching} \alias{pppmatching} \title{Create a Point Matching} \description{ Creates an object of class \code{"pppmatching"} representing a matching of two planar point patterns (objects of class \code{"ppp"}). } \usage{ pppmatching(X, Y, am, type = NULL, cutoff = NULL, q = NULL, mdist = NULL) } \arguments{ \item{X,Y}{Two point patterns (objects of class \code{"ppp"}).} \item{am}{ An \code{npoints(X)} by \code{npoints(Y)} matrix with entries \eqn{\geq 0}{>= 0} that specifies which points are matched and with what weight; alternatively, an object that can be coerced to this form by \code{as.matrix}. } \item{type}{ A character string giving the type of the matching. One of \code{"spa"}, \code{"ace"} or \code{"mat"}, or \code{NULL} for a generic or unknown matching. } \item{cutoff, q}{ Numerical values specifying the cutoff value \eqn{> 0} for interpoint distances and the order \eqn{q \in [1,\infty]}{q in [0,Inf]} of the average that is applied to them. \code{NULL} if not applicable or unknown. } \item{mdist}{ Numerical value for the distance to be associated with the matching. } } \details{ The argument \code{am} is interpreted as a "generalized adjacency matrix": if the \code{[i,j]}-th entry is positive, then the \code{i}-th point of \code{X} and the \code{j}-th point of \code{Y} are matched and the value of the entry gives the corresponding weight of the match. For an unweighted matching all the weights should be set to \eqn{1}. The remaining arguments are optional and allow to save additional information about the matching. See the help files for \code{\link{pppdist}} and \code{\link{matchingdist}} for details on the meaning of these parameters. } \author{ \dominic. } \seealso{ \code{\link{pppmatching.object}} \code{\link{matchingdist}} } \examples{ # a random unweighted complete matching X <- runifrect(10) Y <- runifrect(10) am <- r2dtable(1, rep(1,10), rep(1,10))[[1]] # generates a random permutation matrix m <- pppmatching(X, Y, am) summary(m) m$matrix plot(m) # a random weighted complete matching X <- runifrect(7) Y <- runifrect(7) am <- r2dtable(1, rep(10,7), rep(10,7))[[1]]/10 # generates a random doubly stochastic matrix m2 <- pppmatching(X, Y, am) summary(m2) m2$matrix plot(m2) m3 <- pppmatching(X, Y, am, "ace") m4 <- pppmatching(X, Y, am, "mat") } \keyword{spatial} \keyword{datagen} spatstat.geom/man/ppp.Rd0000644000176200001440000002274214611065350014714 0ustar liggesusers\name{ppp} \alias{ppp} \title{Create a Point Pattern} \description{ Creates an object of class \code{"ppp"} representing a point pattern dataset in the two-dimensional plane. } \usage{ ppp(x,y, \dots, window, marks, check=TRUE, checkdup=check, drop=TRUE) } \arguments{ \item{x}{Vector of \eqn{x} coordinates of data points} \item{y}{Vector of \eqn{y} coordinates of data points} \item{window}{window of observation, an object of class \code{"owin"}} \item{\dots}{arguments passed to \code{\link{owin}} to create the window, if \code{window} is missing} \item{marks}{(optional) mark values for the points. A vector or data frame.} \item{check}{ Logical value indicating whether to check that all the \eqn{(x,y)} points lie inside the specified window. Do not set this to \code{FALSE} unless you are absolutely sure that this check is unnecessary. See Warnings below. } \item{checkdup}{ Logical value indicating whether to check for duplicated coordinates. See Warnings below. } \item{drop}{ Logical flag indicating whether to simplify data frames of marks. See Details. } } \value{ An object of class \code{"ppp"} describing a point pattern in the two-dimensional plane (see \code{\link{ppp.object}}). } \details{ In the \pkg{spatstat} library, a point pattern dataset is described by an object of class \code{"ppp"}. This function creates such objects. The vectors \code{x} and \code{y} must be numeric vectors of equal length. They are interpreted as the cartesian coordinates of the points in the pattern. Note that \code{x} and \code{y} are permitted to have length zero, corresponding to an empty point pattern; this is the default if these arguments are missing. A point pattern dataset is assumed to have been observed within a specific region of the plane called the observation window. An object of class \code{"ppp"} representing a point pattern contains information specifying the observation window. This window must always be specified when creating a point pattern dataset; there is intentionally no default action of ``guessing'' the window dimensions from the data points alone. You can specify the observation window in several (mutually exclusive) ways: \itemize{ \item \code{xrange, yrange} specify a rectangle with these dimensions; \item \code{poly} specifies a polygonal boundary. If the boundary is a single polygon then \code{poly} must be a list with components \code{x,y} giving the coordinates of the vertices. If the boundary consists of several disjoint polygons then \code{poly} must be a list of such lists so that \code{poly[[i]]$x} gives the \eqn{x} coordinates of the vertices of the \eqn{i}th boundary polygon. \item \code{mask} specifies a binary pixel image with entries that are \code{TRUE} if the corresponding pixel is inside the window. \item \code{window} is an object of class \code{"owin"} specifying the window. A window object can be created by \code{\link{owin}} from raw coordinate data. Special shapes of windows can be created by the functions \code{\link{square}}, \code{\link{hexagon}}, \code{\link{regularpolygon}}, \code{\link{disc}} and \code{\link{ellipse}}. See the Examples. } The arguments \code{xrange, yrange} or \code{poly} or \code{mask} are passed to the window creator function \code{\link{owin}} for interpretation. See \code{\link{owin}} for further details. The argument \code{window}, if given, must be an object of class \code{"owin"}. It is a full description of the window geometry, and could have been obtained from \code{\link{owin}} or \code{\link{as.owin}}, or by just extracting the observation window of another point pattern, or by manipulating such windows. See \code{\link{owin}} or the Examples below. The points with coordinates \code{x} and \code{y} \bold{must} lie inside the specified window, in order to define a valid object of this class. Any points which do not lie inside the window will be removed from the point pattern, and a warning will be issued. See the section on Rejected Points. The name of the unit of length for the \code{x} and \code{y} coordinates can be specified in the dataset, using the argument \code{unitname}, which is passed to \code{\link{owin}}. See the examples below, or the help file for \code{\link{owin}}. The optional argument \code{marks} is given if the point pattern is marked, i.e. if each data point carries additional information. For example, points which are classified into two or more different types, or colours, may be regarded as having a mark which identifies which colour they are. Data recording the locations and heights of trees in a forest can be regarded as a marked point pattern where the mark is the tree height. The argument \code{marks} can be either \itemize{ \item a vector, of the same length as \code{x} and \code{y}, which is interpreted so that \code{marks[i]} is the mark attached to the point \code{(x[i],y[i])}. If the mark is a real number then \code{marks} should be a numeric vector, while if the mark takes only a finite number of possible values (e.g. colours or types) then \code{marks} should be a \code{factor}. \item a data frame, with the number of rows equal to the number of points in the point pattern. The \code{i}th row of the data frame is interpreted as containing the mark values for the \code{i}th point in the point pattern. The columns of the data frame correspond to different mark variables (e.g. tree species and tree diameter). } If \code{drop=TRUE} (the default), then a data frame with only one column will be converted to a vector, and a data frame with no columns will be converted to \code{NULL}. See \code{\link{ppp.object}} for a description of the class \code{"ppp"}. Users would normally invoke \code{ppp} to create a point pattern, but the functions \code{\link{as.ppp}} and \code{scanpp} may sometimes be convenient. } \section{Invalid coordinate values}{ The coordinate vectors \code{x} and \code{y} must contain only finite numerical values. If the coordinates include any of the values \code{NA}, \code{NaN}, \code{Inf} or \code{-Inf}, these will be removed. } \section{Rejected points}{ The points with coordinates \code{x} and \code{y} \bold{must} lie inside the specified window, in order to define a valid object of class \code{"ppp"}. Any points which do not lie inside the window will be removed from the point pattern, and a warning will be issued. The rejected points are still accessible: they are stored as an attribute of the point pattern called \code{"rejects"} (which is an object of class \code{"ppp"} containing the rejected points in a large window). However, rejected points in a point pattern will be ignored by all other functions except \code{\link{plot.ppp}}. To remove the rejected points altogether, use \code{\link{as.ppp}}. To include the rejected points, you will need to find a larger window that contains them, and use this larger window in a call to \code{ppp}. } \section{Warnings}{ The code will check for problems with the data, and issue a warning if any problems are found. The checks and warnings can be switched off, for efficiency's sake, but this should only be done if you are confident that the data do not have these problems. Setting \code{check=FALSE} will disable all the checking procedures: the check for points outside the window, and the check for duplicated points. This is extremely dangerous, because points lying outside the window will break many of the procedures in \pkg{spatstat}, causing crashes and strange errors. Set \code{check=FALSE} only if you are absolutely sure that there are no points outside the window. If duplicated points are found, a warning is issued, but no action is taken. Duplicated points are not illegal, but may cause unexpected problems later. Setting \code{checkdup=FALSE} will disable the check for duplicated points. Do this only if you already know the answer. Methodology and software for spatial point patterns often assume that all points are distinct so that there are no duplicated points. If duplicated points are present, the consequence could be an incorrect result or a software crash. To the best of our knowledge, all \pkg{spatstat} code handles duplicated points correctly. However, if duplicated points are present, we advise using \code{\link{unique.ppp}} or \code{\link{multiplicity.ppp}} to eliminate duplicated points and re-analyse the data. } \seealso{ \code{\link{ppp.object}}, \code{\link{as.ppp}}, \code{\link{owin.object}}, \code{\link{owin}}, \code{\link{as.owin}} } \examples{ # some arbitrary coordinates in [0,1] x <- runif(20) y <- runif(20) # the following are equivalent X <- ppp(x, y, c(0,1), c(0,1)) X <- ppp(x, y) X <- ppp(x, y, window=owin(c(0,1),c(0,1))) # specify that the coordinates are given in metres X <- ppp(x, y, c(0,1), c(0,1), unitname=c("metre","metres")) # plot(X) # marks m <- sample(1:2, 20, replace=TRUE) m <- factor(m, levels=1:2) X <- ppp(x, y, c(0,1), c(0,1), marks=m) # polygonal window X <- ppp(x, y, poly=list(x=c(0,10,0), y=c(0,0,10))) # circular window of radius 2 X <- ppp(x, y, window=disc(2)) # copy the window from another pattern X <- ppp(x, y, window=Window(cells)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/Math.imlist.Rd0000644000176200001440000000740714611065344016312 0ustar liggesusers\name{Math.imlist} \alias{Math.imlist} \alias{Ops.imlist} \alias{Complex.imlist} \alias{Summary.imlist} \title{S3 Group Generic methods for List of Images} \description{ These are group generic methods for the class \code{"imlist"} of lists of images. These methods allows the usual mathematical functions and operators to be applied directly to lists of images. See Details for a list of implemented functions. } \usage{ ## S3 methods for group generics have prototypes: \special{Math(x, \dots)} \special{Ops(e1, e2)} \special{Complex(z)} \special{Summary(\dots, na.rm = TRUE)} %NAMESPACE S3method("Math", "imlist") %NAMESPACE S3method("Ops", "imlist") %NAMESPACE S3method("Complex", "imlist") %NAMESPACE S3method("Summary", "imlist") } \arguments{ \item{x,z,e1,e2}{ Lists of pixel images (objects of class \code{"imlist"}). } \item{\dots}{further arguments passed to methods.} \item{na.rm}{logical: should missing values be removed?} } \details{ An object of class \code{"imlist"} represents a list of pixel images. It is a \code{list}, whose entries are pixel images (objects of class \code{"im"}). The following mathematical functions and operators are defined for lists of images. Not all functions will make sense for all types of images. For example, none of the functions in the \code{"Math"} group make sense for character-valued images. Note that the \code{"Ops"} group methods are implemented using \code{\link{eval.im}}, which tries to harmonise images via \code{\link{harmonise.im}} if they aren't compatible to begin with. \enumerate{ \item Group \code{"Math"}: \itemize{ \item \code{abs}, \code{sign}, \code{sqrt},\cr \code{floor}, \code{ceiling}, \code{trunc},\cr \code{round}, \code{signif} \item \code{exp}, \code{log}, \code{expm1}, \code{log1p},\cr \code{cos}, \code{sin}, \code{tan},\cr \code{cospi}, \code{sinpi}, \code{tanpi},\cr \code{acos}, \code{asin}, \code{atan} \code{cosh}, \code{sinh}, \code{tanh},\cr \code{acosh}, \code{asinh}, \code{atanh} \item \code{lgamma}, \code{gamma}, \code{digamma}, \code{trigamma} \item \code{cumsum}, \code{cumprod}, \code{cummax}, \code{cummin} } \item Group \code{"Ops"}: \itemize{ \item \code{"+"}, \code{"-"}, \code{"*"}, \code{"/"}, \code{"^"}, \code{"\%\%"}, \code{"\%/\%"} \item \code{"&"}, \code{"|"}, \code{"!"} \item \code{"=="}, \code{"!="}, \code{"<"}, \code{"<="}, \code{">="}, \code{">"} } \item Group \code{"Summary"}: \itemize{ \item \code{all}, \code{any} \item \code{sum}, \code{prod} \item \code{min}, \code{max} \item \code{range} } \item Group \code{"Complex"}: \itemize{ \item \code{Arg}, \code{Conj}, \code{Im}, \code{Mod}, \code{Re} } } For the binary operations in \code{"Ops"}, either \itemize{ \item \code{e1} and \code{e2} are lists of pixel images, and contain the same number of images. % \item one of \code{e1,e2} is a list of pixel images, % and the other is an individual pixel image (class \code{"im"}). \item one of \code{e1,e2} is a list of pixel images, and the other is a single atomic value. } } \value{ The result of \code{"Math"}, \code{"Ops"} and \code{"Complex"} group operations is another list of images. The result of \code{"Summary"} group operations is a numeric vector of length 1 or 2. } \seealso{ \code{\link{Math.im}} or \code{\link{eval.im}} for evaluating expressions involving images. \code{\link{solapply}} for a wrapper for \code{\link[base]{lapply}}. } \examples{ a <- solist(A=setcov(square(1)), B=setcov(square(2))) log(a)/2 - sqrt(a) range(a) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} spatstat.geom/man/ellipse.Rd0000644000176200001440000000416314643111575015555 0ustar liggesusers\name{ellipse} \alias{ellipse} \title{ Elliptical Window. } \description{ Create an elliptical window. } \usage{ ellipse(a, b, centre=c(0,0), phi=0, \dots, mask=FALSE, npoly = 128) } \arguments{ \item{a,b}{ The half-lengths of the axes of the ellipse. } \item{centre}{ The centre of the ellipse. } \item{phi}{ The (anti-clockwise) angle through which the ellipse should be rotated (about its centre) starting from an orientation in which the axis of half-length \code{a} is horizontal. } \item{mask}{ Logical value controlling the type of approximation to a perfect ellipse. See Details. } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution, if \code{mask} is \code{TRUE}. } \item{npoly}{ The number of edges in the polygonal approximation to the ellipse. } } \details{ This command creates a window object representing an ellipse with the given centre and axes. By default, the ellipse is approximated by a polygon with \code{npoly} edges. If \code{mask=TRUE}, then the ellipse is approximated by a binary pixel mask. The resolution of the mask is controlled by the arguments \code{\dots} which are passed to \code{\link[spatstat.geom]{as.mask}}. The arguments \code{a} and \code{b} must be single positive numbers. The argument \code{centre} specifies the ellipse centre: it can be either a numeric vector of length 2 giving the coordinates, or a \code{list(x,y)} giving the coordinates of exactly one point, or a point pattern (object of class \code{"ppp"}) containing exactly one point. } \value{ An object of class \code{owin} (either of type \dQuote{polygonal} or of type \dQuote{mask}) specifying an elliptical window. } \author{ \adrian and \rolf. } \seealso{ \code{\link{disc}}, \code{\link{owin.object}}, \code{\link{owin}}, \code{\link[spatstat.geom]{as.mask}} } \examples{ W <- ellipse(a=5,b=2,centre=c(5,1),phi=pi/6) plot(W,lwd=2,border="red") WM <- ellipse(a=5,b=2,centre=c(5,1),phi=pi/6,mask=TRUE,dimyx=64) plot(WM,add=TRUE,box=FALSE) } \keyword{spatial} \keyword{datagen} spatstat.geom/man/default.symbolmap.ppp.Rd0000644000176200001440000002121714611065345020341 0ustar liggesusers\name{default.symbolmap.ppp} \alias{default.symbolmap.ppp} \title{ Default Symbol Map for Point Pattern } \description{ Determines a symbol map for plotting the spatial point pattern \code{x}. } \usage{ \method{default.symbolmap}{ppp}(x, \dots, chars = NULL, cols = NULL, fixsize = FALSE, maxsize = NULL, meansize = NULL, markscale = NULL, minsize = NULL, zerosize = NULL, marktransform = NULL) } \arguments{ \item{x}{ A spatial point pattern (object of class \code{"ppp"}). } \item{\dots}{ extra graphical parameters, passed to \code{\link{symbolmap}} (and ultimately to \code{\link{points}} and/or \code{\link{symbols}}). } \item{chars}{ the plotting character(s) used to plot points. Either a single character, an integer, or a vector of single characters or integers. Ignored if \code{symap} is given. } \item{cols}{ the colour(s) used to plot points. Either an integer index from 1 to 8 (indexing the standard colour palette), a character string giving the name of a colour, or a string giving the hexadecimal representation of a colour, or a vector of such integers or strings. See the section on \emph{Colour Specification} in the help for \code{\link[graphics]{par}}. } \item{fixsize}{ Logical value specifying whether the symbols should all have the same physical size on the plot. Default is \code{FALSE}. } \item{maxsize}{ \emph{Maximum} physical size of the circles/squares plotted when \code{x} is a marked point pattern with numerical marks. Incompatible with \code{meansize} and \code{markscale}. } \item{meansize}{ \emph{Average} physical size of the circles/squares plotted when \code{x} is a marked point pattern with numerical marks. Incompatible with \code{maxsize} and \code{markscale}. } \item{markscale}{ physical scale factor determining the sizes of the circles/squares plotted when \code{x} is a marked point pattern with numerical marks. Mark value will be multiplied by \code{markscale} to determine physical size. Incompatible with \code{maxsize} and \code{meansize}. } \item{minsize}{ \emph{Minimum} physical size of the circles/squares plotted when \code{x} is a marked point pattern with numerical marks. Incompatible with \code{zerosize}. } \item{zerosize}{ Physical size of the circle/square representing a mark value of zero, when \code{x} is a marked point pattern with numerical marks. Incompatible with \code{minsize}. Defaults to zero. } \item{marktransform}{ Experimental. A function that should be applied to the mark values before the symbol mapping is applied. } } \details{ This algorithm determines a symbol map that can be used to represent the points of \code{x} graphically. It serves as the default symbol map for the plot method \code{\link{plot.ppp}}. Users can modify the behaviour of \code{\link{plot.ppp}} by saving the symbol map produced by \code{default.symbolmap}, modifying the symbol map using \code{\link{update.symbolmap}} or other tools, and passing the modified symbol map to \code{\link{plot.ppp}} as the argument \code{symap}. The default representation depends on the marks of the points, as follows. \describe{ \item{unmarked point pattern:}{ If the point pattern does not have marks, then every point will be represented by the same plot symbol. } \item{multitype point pattern:}{ If \code{marks(x)} is a factor, then each level of the factor is represented by a different plot character. } \item{continuous marks:}{ If \code{marks(x)} is a numeric vector, each point is represented by a circle with \emph{diameter} proportional to the mark (if the value is positive) or a square with \emph{side length} proportional to the absolute value of the mark (if the value is negative). } \item{other kinds of marks:}{ If \code{marks(x)} is neither numeric nor a factor, then each possible mark will be represented by a different plotting character. The default is to represent the \eqn{i}th smallest mark value by \code{points(..., pch=i)}. } } The following arguments can be used to modify how the points are plotted: \itemize{ \item If \code{fixsize=TRUE}, or if the graphics parameter \code{size} is given and is a single value, then numerical marks will be rendered as symbols of the same physical size \item The argument \code{chars} determines the plotting character or characters used to display the points (in all cases except for the case of continuous marks). For an unmarked point pattern, this should be a single integer or character determining a plotting character (see \code{par("pch")}). For a multitype point pattern, \code{chars} should be a vector of integers or characters, of the same length as \code{levels(marks(x))}, and then the \eqn{i}th level or type will be plotted using character \code{chars[i]}. \item If \code{chars} is absent, but there is an extra argument \code{pch}, then this will determine the plotting character for all points. \item The argument \code{cols} determines the colour or colours used to display the points. For an unmarked point pattern, \code{cols} should be a character string determining a colour. For a multitype point pattern, \code{cols} should be a character vector, of the same length as \code{levels(marks(x))}: that is, there is one colour for each possible mark value. The \eqn{i}th level or type will be plotted using colour \code{cols[i]}. For a point pattern with continuous marks, \code{cols} can be either a character string or a character vector specifying colour values: the range of mark values will be mapped to the specified colours. Alternatively, for any kind of data, \code{cols} can be a colour map (object of class \code{"colourmap"}) created by \code{\link{colourmap}}. \item If \code{cols} is absent, the colours used to plot the points may be determined by the extra arguments \code{fg} and \code{bg} for foreground (edge) and background (fill) colours. (These parameters are not recommended for plotting multitype point patterns, due to quirks of the graphics system.) \item The default colour for the points is a semi-transparent grey, if this is supported by the plot device. This behaviour can be suppressed (so that the default colour is non-transparent) by setting \code{spatstat.options(transparent=FALSE)}. \item The arguments \code{maxsize}, \code{meansize} and \code{markscale} are incompatible with each other (and incompatible with \code{symap}). The arguments \code{minsize} and \code{zerosize} are incompatible with each other (and incompatible with \code{symap}). Together, these arguments control the physical size of the circles and squares which represent the marks in a point pattern with continuous marks. The size of a circle is defined as its \emph{diameter}; the size of a square is its side length. If \code{markscale} is given, then a mark value of \code{m} is plotted as a circle of diameter \code{m * markscale + zerosize} (if \code{m} is positive) or a square of side \code{abs(m) * markscale + zerosize} (if \code{m} is negative). If \code{maxsize} is given, then the largest mark in absolute value, \code{mmax=max(abs(marks(x)))}, will be scaled to have physical size \code{maxsize}. If \code{meansize} is given, then the average absolute mark value, \code{mmean=mean(abs(marks(x)))}, will be scaled to have physical size \code{meansize}. If \code{minsize} is given, then the minimum mark value, \code{mmean=mean(abs(marks(x)))}, will be scaled to have physical size \code{minsize}. \item The user can set the default values of these plotting parameters using \code{\link{spatstat.options}("par.points")}. } Additionally the user can specify any of the graphics parameters recognised by \code{\link{symbolmap}}, including \code{shape}, \code{size}, \code{pch}, \code{cex}, \code{cols}, \code{col}, \code{fg}, \code{bg}, \code{lwd}, \code{lty}, \code{etch}, \code{direction},\code{headlength},\code{headangle},\code{arrowtype}. } \value{ A symbol map (object of class \code{"symbolmap"}) or a list of symbol maps, one for each column of marks. } \author{ \adrian } \seealso{ \code{\link{plot.ppp}} \code{\link{default.symbolmap}} \code{\link{symbolmap}} } \examples{ default.symbolmap(longleaf) default.symbolmap(lansing) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/bdist.points.Rd0000644000176200001440000000236214611065345016535 0ustar liggesusers\name{bdist.points} \alias{bdist.points} \title{Distance to Boundary of Window} \description{ Computes the distances from each point of a point pattern to the boundary of the window. } \usage{ bdist.points(X) } \arguments{ \item{X}{A point pattern (object of class \code{"ppp"}).} } \value{ A numeric vector, giving the distances from each point of the pattern to the boundary of the window. } \details{ This function computes, for each point \eqn{x_i}{x[i]} in the point pattern \code{X}, the shortest distance \eqn{d(x_i, W^c)}{dist(x[i], W')} from \eqn{x_i}{x[i]} to the boundary of the window \eqn{W} of observation. If the window \code{Window(X)} is of type \code{"rectangle"} or \code{"polygonal"}, then these distances are computed by analytic geometry and are exact, up to rounding errors. If the window is of type \code{"mask"} then the distances are computed using the real-valued distance transform, which is an approximation with maximum error equal to the width of one pixel in the mask. } \seealso{ \code{\link{bdist.pixels}}, \code{\link{bdist.tiles}}, \code{\link{ppp.object}}, \code{\link{erosion}} } \examples{ d <- bdist.points(cells) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/print.im.Rd0000644000176200001440000000116514611065350015651 0ustar liggesusers\name{print.im} \alias{print.im} \title{Print Brief Details of an Image} \description{ Prints a very brief description of a pixel image object. } \usage{ \method{print}{im}(x, \dots) } \arguments{ \item{x}{Pixel image (object of class \code{"im"}).} \item{\dots}{Ignored.} } \details{ A very brief description of the pixel image \code{x} is printed. This is a method for the generic function \code{\link{print}}. } \seealso{ \code{\link{print}}, \code{\link{im.object}}, \code{\link{summary.im}} } \examples{ U <- as.im(letterR) U } \author{\adrian and \rolf } \keyword{spatial} \keyword{print} spatstat.geom/man/overlap.owin.Rd0000644000176200001440000000160014611065347016534 0ustar liggesusers\name{overlap.owin} \alias{overlap.owin} \title{ Compute Area of Overlap } \description{ Computes the area of the overlap (intersection) of two windows. } \usage{ overlap.owin(A, B) } \arguments{ \item{A,B}{ Windows (objects of class \code{"owin"}). } } \details{ This function computes the area of the overlap between the two windows \code{A} and \code{B}. If one of the windows is a binary mask, then both windows are converted to masks on the same grid, and the area is computed by counting pixels. Otherwise, the area is computed analytically (using the discrete Stokes theorem). } \value{ A single numeric value. } \seealso{ \code{\link{intersect.owin}}, \code{\link{area.owin}}, \code{\link{setcov}}. } \examples{ A <- square(1) B <- shift(A, c(0.3, 0.2)) overlap.owin(A, B) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math}spatstat.geom/man/pairdist.ppx.Rd0000644000176200001440000000340414742317360016542 0ustar liggesusers\name{pairdist.ppx} \alias{pairdist.ppx} \title{Pairwise Distances in Any Dimensions} \description{ Computes the matrix of distances between all pairs of points in a multi-dimensional point pattern. } \usage{ \method{pairdist}{ppx}(X, \dots) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppx"}). } \item{\dots}{ Arguments passed to \code{\link{coords.ppx}} to determine which coordinates should be used. } } \value{ A square matrix whose \code{[i,j]} entry is the distance between the points numbered \code{i} and \code{j}. } \details{ This is a method for the generic function \code{pairdist}. Given a multi-dimensional point pattern \code{X} (an object of class \code{"ppx"}), this function computes the Euclidean distances between all pairs of points in \code{X}, and returns the matrix of distances. By default, both spatial and temporal coordinates are extracted. To obtain the spatial distance between points in a space-time point pattern, set \code{temporal=FALSE}. } \section{Distance values}{ The values returned by \code{pairdist(X, temporal=FALSE)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{pairdist(X, temporal=FALSE)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{pairdist}}, \code{\link{crossdist}}, \code{\link{nndist}} } \examples{ df <- data.frame(x=runif(4),y=runif(4),z=runif(4),w=runif(4)) X <- ppx(data=df) pairdist(X) } \author{ \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/regularpolygon.Rd0000644000176200001440000000350114611065350017156 0ustar liggesusers\name{regularpolygon} \alias{regularpolygon} \alias{hexagon} \title{ Create A Regular Polygon } \description{ Create a window object representing a regular (equal-sided) polygon. } \usage{ regularpolygon(n, edge = 1, centre = c(0, 0), \dots, align = c("bottom", "top", "left", "right", "no")) hexagon(edge = 1, centre = c(0,0), \dots, align = c("bottom", "top", "left", "right", "no")) } \arguments{ \item{n}{ Number of edges in the polygon. } \item{edge}{ Length of each edge in the polygon. A single positive number. } \item{centre}{ Coordinates of the centre of the polygon. A numeric vector of length 2, or a \code{list(x,y)} giving the coordinates of exactly one point, or a point pattern (object of class \code{"ppp"}) containing exactly one point. } \item{align}{ Character string specifying whether to align one of the edges with a vertical or horizontal boundary. } \item{\dots}{ Ignored. } } \details{ The function \code{regularpolygon} creates a regular (equal-sided) polygon with \code{n} sides, centred at \code{centre}, with sides of equal length \code{edge}. The function \code{hexagon} is the special case \code{n=6}. The orientation of the polygon is determined by the argument \code{align}. If \code{align="no"}, one vertex of the polygon is placed on the \eqn{x}-axis. Otherwise, an edge of the polygon is aligned with one side of the frame, specified by the value of \code{align}. } \value{ A window (object of class \code{"owin"}). } \author{ \spatstatAuthors. } \seealso{ \code{\link{disc}}, \code{\link{ellipse}}, \code{\link{owin}}. \code{\link{hextess}} for hexagonal tessellations. } \examples{ plot(hexagon()) plot(regularpolygon(7)) plot(regularpolygon(7, align="left")) } \keyword{spatial} \keyword{datagen} spatstat.geom/man/MinkowskiSum.Rd0000644000176200001440000000730414611065344016555 0ustar liggesusers\name{MinkowskiSum} \alias{MinkowskiSum} \alias{\%(+)\%} %DoNotExport %NAMESPACE export("%(+)%") \alias{dilationAny} \title{Minkowski Sum of Windows} \description{ Compute the Minkowski sum of two spatial windows. } \usage{ MinkowskiSum(A, B) A \%(+)\% B dilationAny(A, B) } \arguments{ \item{A,B}{ Windows (objects of class \code{"owin"}), point patterns (objects of class \code{"ppp"}) or line segment patterns (objects of class \code{"psp"}) in any combination. } } \value{ A window (object of class \code{"owin"}) except that if \code{A} is a point pattern, then the result is an object of the same type as \code{B} (and vice versa). } \details{ The operator \code{A \%(+)\% B} and function \code{MinkowskiSum(A,B)} are synonymous: they both compute the Minkowski sum of the windows \code{A} and \code{B}. The function \code{dilationAny} computes the Minkowski dilation \code{A \%(+)\% reflect(B)}. The Minkowski sum of two spatial regions \eqn{A} and \eqn{B} is another region, formed by taking all possible pairs of points, one in \eqn{A} and one in \eqn{B}, and adding them as vectors. The Minkowski Sum \eqn{A \oplus B}{A \%(+)\% B} is the set of all points \eqn{a+b} where \eqn{a} is in \eqn{A} and \eqn{b} is in \eqn{B}. A few common facts about the Minkowski sum are: \itemize{ \item The sum is symmetric: \eqn{A \oplus B = B \oplus A}{A \%(+)\% B = B \%(+)\% A}. \item If \eqn{B} is a single point, then \eqn{A \oplus B}{A \%(+)\% B} is a shifted copy of \eqn{A}. \item If \eqn{A} is a square of side length \eqn{a}, and \eqn{B} is a square of side length \eqn{b}, with sides that are parallel to the coordinate axes, then \eqn{A \oplus B}{A \%(+)\% B} is a square of side length \eqn{a+b}. \item If \eqn{A} and \eqn{B} are discs of radius \eqn{r} and \eqn{s} respectively, then \eqn{A \oplus B}{A \%(+)\% B} is a disc of redius \eqn{r+s}. \item If \eqn{B} is a disc of radius \eqn{r} centred at the origin, then \eqn{A \oplus B}{A \%(+)\% B} is equivalent to the \emph{morphological dilation} of \eqn{A} by distance \eqn{r}. See \code{\link{dilation}}. } The Minkowski dilation is the closely-related region \eqn{A \oplus (-B)}{A \%(+)\% (-B)} where \eqn{(-B)} is the reflection of \eqn{B} through the origin. The Minkowski dilation is the set of all vectors \eqn{z} such that, if \eqn{B} is shifted by \eqn{z}, the resulting set \eqn{B+z} has nonempty intersection with \eqn{A}. The algorithm currently computes the result as a polygonal window using the \pkg{polyclip} library. It will be quite slow if applied to binary mask windows. The arguments \code{A} and \code{B} can also be point patterns or line segment patterns. These are interpreted as spatial regions, the Minkowski sum is computed, and the result is returned as an object of the most appropriate type. The Minkowski sum of two point patterns is another point pattern. The Minkowski sum of a point pattern and a line segment pattern is another line segment pattern. } \seealso{ \code{\link{dilation}}, \code{\link{erosionAny}} } \examples{ B <- square(0.2) RplusB <- letterR \%(+)\% B opa <- par(mfrow=c(1,2)) FR <- grow.rectangle(Frame(letterR), 0.3) plot(FR, main="") plot(letterR, add=TRUE, lwd=2, hatch=TRUE, hatchargs=list(texture=5)) plot(shift(B, vec=c(3.675, 3)), add=TRUE, border="red", lwd=2) plot(FR, main="") plot(letterR, add=TRUE, lwd=2, hatch=TRUE, hatchargs=list(texture=5)) plot(RplusB, add=TRUE, border="blue", lwd=2, hatch=TRUE, hatchargs=list(col="blue")) par(opa) plot(cells \%(+)\% square(0.1)) } \author{ \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/as.matrix.owin.Rd0000644000176200001440000000224014643111575016773 0ustar liggesusers\name{as.matrix.owin} \alias{as.matrix.owin} \title{Convert Pixel Image to Matrix} \description{ Converts a pixel image to a matrix. } \usage{ \method{as.matrix}{owin}(x, ...) } \arguments{ \item{x}{A window (object of class \code{"owin"}).} \item{\dots}{Arguments passed to \code{\link[spatstat.geom]{as.mask}} to control the pixel resolution.} } \details{ The function \code{as.matrix.owin} converts a window to a logical matrux. It first converts the window \code{x} into a binary pixel mask using \code{\link[spatstat.geom]{as.mask}}. It then extracts the pixel entries as a logical matrix. The resulting matrix has entries that are \code{TRUE} if the corresponding pixel is inside the window, and \code{FALSE} if it is outside. The function \code{as.matrix} is generic. The function \code{as.matrix.owin} is the method for windows (objects of class \code{"owin"}). Use \code{\link{as.im}} to convert a window to a pixel image. } \value{ A logical matrix. } \examples{ m <- as.matrix(letterR) } \seealso{ \code{\link{as.matrix.im}}, \code{\link{as.im}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/methods.distfun.Rd0000644000176200001440000000412114611065347017230 0ustar liggesusers\name{methods.distfun} \alias{methods.distfun} %DoNotExport \alias{shift.distfun} \alias{rotate.distfun} \alias{scalardilate.distfun} \alias{affine.distfun} \alias{flipxy.distfun} \alias{reflect.distfun} \alias{rescale.distfun} \Rdversion{1.1} \title{ Geometrical Operations for Distance Functions } \description{ Methods for objects of the class \code{"distfun"}. } \usage{ \method{shift}{distfun}(X, \dots) \method{rotate}{distfun}(X, \dots) \method{scalardilate}{distfun}(X, \dots) \method{affine}{distfun}(X, \dots) \method{flipxy}{distfun}(X) \method{reflect}{distfun}(X) \method{rescale}{distfun}(X, s, unitname) } \arguments{ \item{X}{ Object of class \code{"distfun"} representing the distance function of a spatial object. } \item{\dots}{ Arguments passed to the next method for the geometrical operation. See Details. } \item{s, unitname}{ Arguments passed to the next method for \code{\link{rescale}}. } } \details{ These are methods for the generic functions \code{\link{shift}}, \code{\link{rotate}}, \code{\link{scalardilate}}, \code{\link{affine}}, \code{\link{flipxy}} and \code{\link{reflect}} which perform geometrical operations on spatial objects, and for the generic \code{\link{rescale}} which changes the unit of length. The argument \code{X} should be an object of class \code{"distfun"} representing the distance function of a spatial object \code{Y}. Objects of class \code{"distfun"} are created by \code{\link{distfun}}. The methods apply the specified geometrical transformation to the original object \code{Y}, producing a new object \code{Z} of the same type as \code{Y}. They then create a new \code{distfun} object representing the distance function of \code{Z}. } \value{ Another object of class \code{"distfun"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{distfun}}, \code{\link{methods.funxy}}. } \examples{ (f <- distfun(letterR)) plot(f) flipxy(f) shift(f, origin="midpoint") plot(rotate(f, angle=pi/2)) (g <- distfun(lansing)) rescale(g) } \keyword{spatial} \keyword{methods} spatstat.geom/man/intersect.owin.Rd0000644000176200001440000000620314643111575017070 0ustar liggesusers\name{intersect.owin} \alias{intersect.owin} \alias{union.owin} \alias{setminus.owin} \title{Intersection, Union or Set Subtraction of Windows} \description{ Yields the intersection, union or set subtraction of windows. } \usage{ intersect.owin(\dots, fatal=FALSE, p) union.owin(\dots, p) setminus.owin(A, B, \dots, p) } \arguments{ \item{A,B}{Windows (objects of class \code{"owin"}).} \item{\dots}{ Windows, or arguments passed to \code{\link[spatstat.geom]{as.mask}} to control the discretisation. } \item{fatal}{Logical. Determines what happens if the intersection is empty. } \item{p}{ Optional list of parameters passed to \code{\link[polyclip]{polyclip}} to control the accuracy of polygon geometry. } } \value{ A window (object of class \code{"owin"}) or possibly \code{NULL}. } \details{ The function \code{intersect.owin} computes the intersection between the windows given in \code{\dots}, while \code{union.owin} computes their union. The function \code{setminus.owin} computes the intersection of \code{A} with the complement of \code{B}. For \code{intersect.owin} and \code{union.owin}, the arguments \code{\dots} must be either \itemize{ \item window objects of class \code{"owin"}, \item data that can be coerced to this class by \code{\link{as.owin}}), \item lists of windows, of class \code{"solist"}, \item named arguments of \code{\link[spatstat.geom]{as.mask}} to control the discretisation if required. } For \code{setminus.owin}, the arguments \code{\dots} must be named arguments of \code{\link[spatstat.geom]{as.mask}}. If the intersection is empty, then if \code{fatal=FALSE} the result is an empty window or \code{NULL}, while if \code{fatal=TRUE} an error occurs. } \author{ \spatstatAuthors. } \seealso{ \code{\link{is.subset.owin}}, \code{\link{overlap.owin}}, \code{\link{is.empty}}, \code{\link{boundingbox}}, \code{\link{owin.object}} } \examples{ # rectangles u <- unit.square() v <- owin(c(0.5,3.5), c(0.4,2.5)) # polygon letterR # mask m <- as.mask(letterR) # two rectangles intersect.owin(u, v) union.owin(u,v) setminus.owin(u,v) # polygon and rectangle intersect.owin(letterR, v) union.owin(letterR,v) setminus.owin(letterR,v) # mask and rectangle intersect.owin(m, v) union.owin(m,v) setminus.owin(m,v) # mask and polygon p <- rotate(v, 0.2) intersect.owin(m, p) union.owin(m,p) setminus.owin(m,p) # two polygons A <- letterR B <- rotate(letterR, 0.2) plot(boundingbox(A,B), main="intersection") w <- intersect.owin(A, B) plot(w, add=TRUE, col="lightblue") plot(A, add=TRUE) plot(B, add=TRUE) plot(boundingbox(A,B), main="union") w <- union.owin(A,B) plot(w, add=TRUE, col="lightblue") plot(A, add=TRUE) plot(B, add=TRUE) plot(boundingbox(A,B), main="set minus") w <- setminus.owin(A,B) plot(w, add=TRUE, col="lightblue") plot(A, add=TRUE) plot(B, add=TRUE) # intersection and union of three windows C <- shift(B, c(0.2, 0.3)) plot(union.owin(A,B,C)) plot(intersect.owin(A,B,C)) } \keyword{spatial} \keyword{math} spatstat.geom/man/shift.owin.Rd0000644000176200001440000000455614611065350016210 0ustar liggesusers\name{shift.owin} \alias{shift.owin} \title{Apply Vector Translation To Window} \description{ Applies a vector shift to a window } \usage{ \method{shift}{owin}(X, vec=c(0,0), \dots, origin=NULL) } \arguments{ \item{X}{Window (object of class \code{"owin"}).} \item{vec}{Vector of length 2 representing a translation.} \item{\dots}{Ignored} \item{origin}{ Location that will be shifted to the origin. Either a numeric vector of length 2 giving the location, or a point pattern containing only one point, or a list with two entries named \code{x} and \code{y}, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). } } \value{ Another window (of class \code{"owin"}) representing the result of applying the vector shift. } \details{ The window is translated by the vector \code{vec}. This is a method for the generic function \code{\link{shift}}. If \code{origin} is given, the argument \code{vec} will be ignored; instead the shift will be performed so that the specified geometric location is shifted to the coordinate origin \eqn{(0,0)}. The argument \code{origin} should be either a numeric vector of length 2 giving the spatial coordinates of a location, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). If \code{origin="centroid"} then the centroid of the window will be shifted to the origin. If \code{origin="midpoint"} then the centre of the bounding rectangle of the window will be shifted to the origin. If \code{origin="bottomleft"} then the bottom left corner of the bounding rectangle of the window will be shifted to the origin, and so on. } \seealso{ \code{\link{shift}}, \code{\link{shift.ppp}}, \code{\link{periodify}}, \code{\link{rotate}}, \code{\link{affine}}, \code{\link{centroid.owin}} } \examples{ W <- owin(c(0,1),c(0,1)) X <- shift(W, c(2,3)) # plot(W) # no discernible difference except coordinates are different shift(W, origin="top") } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/headtail.Rd0000644000176200001440000000354014611065346015670 0ustar liggesusers\name{headtail} \alias{head.ppp} \alias{head.ppx} \alias{head.psp} \alias{head.tess} \alias{tail.ppp} \alias{tail.ppx} \alias{tail.psp} \alias{tail.tess} \title{ First or Last Part of a Spatial Pattern } \description{ Returns the first few elements (\code{head}) or the last few elements (\code{tail}) of a spatial pattern. } \usage{ \method{head}{ppp}(x, n = 6L, \dots) \method{head}{ppx}(x, n = 6L, \dots) \method{head}{psp}(x, n = 6L, \dots) \method{head}{tess}(x, n = 6L, \dots) \method{tail}{ppp}(x, n = 6L, \dots) \method{tail}{ppx}(x, n = 6L, \dots) \method{tail}{psp}(x, n = 6L, \dots) \method{tail}{tess}(x, n = 6L, \dots) } \arguments{ \item{x}{ A spatial pattern of geometrical figures, such as a spatial pattern of points (an object of class \code{"ppp"}, \code{"pp3"}, \code{"ppx"} or \code{"lpp"}) or a spatial pattern of line segments (an object of class \code{"psp"}) or a tessellation (object of class \code{"tess"}). } \item{n}{ Integer. The number of elements of the pattern that should be extracted. } \item{\dots}{ Ignored. } } \details{ These are methods for the generic functions \code{\link[utils]{head}} and \code{\link[utils]{tail}}. They extract the first or last \code{n} elements from \code{x} and return them as an object of the same kind as \code{x}. To inspect the spatial coordinates themselves, use \code{\link[utils]{View}(x)} or \code{head(as.data.frame(x))}. } \value{ An object of the same class as \code{x}. } \author{ \spatstatAuthors. } \seealso{ \code{\link[utils]{View}}, \code{\link[utils]{edit}}. Conversion to data frame: \code{\link{as.data.frame.ppp}}, \code{\link{as.data.frame.ppx}}, \code{\link{as.data.frame.psp}} } \examples{ head(cells) tail(edges(letterR), 5) head(dirichlet(cells), 4) } \keyword{spatial} \keyword{manip} spatstat.geom/man/nnwhich.pp3.Rd0000644000176200001440000000511614611065347016256 0ustar liggesusers\name{nnwhich.pp3} \alias{nnwhich.pp3} \title{Nearest neighbours in three dimensions} \description{ Finds the nearest neighbour of each point in a three-dimensional point pattern. } \usage{ \method{nnwhich}{pp3}(X, \dots, k=1) } \arguments{ \item{X}{ Three-dimensional point pattern (object of class \code{"pp3"}). } \item{\dots}{ Ignored. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } } \value{ Numeric vector or matrix giving, for each point, the index of its nearest neighbour (or \code{k}th nearest neighbour). If \code{k = 1} (the default), the return value is a numeric vector \code{v} giving the indices of the nearest neighbours (the nearest neighbout of the \code{i}th point is the \code{j}th point where \code{j = v[i]}). If \code{k} is a single integer, then the return value is a numeric vector giving the indices of the \code{k}th nearest neighbours. If \code{k} is a vector, then the return value is a matrix \code{m} such that \code{m[i,j]} is the index of the \code{k[j]}th nearest neighbour for the \code{i}th data point. } \details{ For each point in the given three-dimensional point pattern, this function finds its nearest neighbour (the nearest other point of the pattern). By default it returns a vector giving, for each point, the index of the point's nearest neighbour. If \code{k} is specified, the algorithm finds each point's \code{k}th nearest neighbour. The function \code{nnwhich} is generic. This is the method for the class \code{"pp3"}. If there are no points in the pattern, a numeric vector of length zero is returned. If there is only one point, then the nearest neighbour is undefined, and a value of \code{NA} is returned. In general if the number of points is less than or equal to \code{k}, then a vector of \code{NA}'s is returned. To evaluate the \emph{distance} between a point and its nearest neighbour, use \code{\link{nndist}}. To find the nearest neighbours from one point pattern to another point pattern, use \code{\link{nncross}}. } \section{Warnings}{ A value of \code{NA} is returned if there is only one point in the point pattern. } \seealso{ \code{\link{nnwhich}}, \code{\link{nndist}}, \code{\link{nncross}} } \examples{ if(require(spatstat.random)) { X <- runifpoint3(30) } else { X <- osteo$pts[[1]] } m <- nnwhich(X) m2 <- nnwhich(X, k=2) } \author{ \adrian based on two-dimensional code by \pavel. } \keyword{spatial} \keyword{math} \concept{Three-dimensional} spatstat.geom/man/summary.owin.Rd0000644000176200001440000000143214611065350016556 0ustar liggesusers\name{summary.owin} \alias{summary.owin} \title{Summary of a Spatial Window} \description{ Prints a useful description of a window object. } \usage{ \method{summary}{owin}(object, \dots) } \arguments{ \item{object}{Window (object of class \code{"owin"}).} \item{\dots}{Ignored.} } \details{ A useful description of the window \code{object} is printed. This is a method for the generic function \code{\link{summary}}. } \seealso{ \code{\link{summary}}, \code{\link{summary.ppp}}, \code{\link{print.owin}} } \examples{ summary(owin()) # the unit square W <- Window(demopat) # weird polygonal window summary(W) # describes it summary(as.mask(W)) # demonstrates current pixel resolution } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/plot.anylist.Rd0000644000176200001440000002213114721742045016552 0ustar liggesusers\name{plot.anylist} \alias{plot.anylist} \title{Plot a List of Things} \description{ Plots a list of things } \usage{ \method{plot}{anylist}(x, \dots, main, arrange=TRUE, nrows=NULL, ncols=NULL, main.panel=NULL, mar.panel=c(2,1,1,2), hsep=0, vsep=0, panel.begin=NULL, panel.end=NULL, panel.args=NULL, panel.begin.args=NULL, panel.end.args=NULL, panel.vpad=0.2, plotcommand="plot", adorn.left=NULL, adorn.right=NULL, adorn.top=NULL, adorn.bottom=NULL, adorn.size=0.2, adorn.args=list(), equal.scales=FALSE, halign=FALSE, valign=FALSE) } \arguments{ \item{x}{ An object of the class \code{"anylist"}. Essentially a list of objects. } \item{\dots}{ Arguments passed to \code{\link{plot}} when generating each plot panel. } \item{main}{ Overall heading for the plot. } \item{arrange}{ Logical flag indicating whether to plot the objects side-by-side on a single page (\code{arrange=TRUE}) or plot them individually in a succession of frames (\code{arrange=FALSE}). } \item{nrows,ncols}{ Optional. The number of rows/columns in the plot layout (assuming \code{arrange=TRUE}). You can specify either or both of these numbers. } \item{main.panel}{ Optional. A character string, or a vector of character strings, giving the headings for each of the objects. } \item{mar.panel}{ Size of the margins outside each plot panel. A numeric vector of length 4 giving the bottom, left, top, and right margins in that order. (Alternatively the vector may have length 1 or 2 and will be replicated to length 4). See the section on \emph{Spacing between plots}. } \item{hsep,vsep}{ Additional horizontal and vertical separation between plot panels, expressed in the same units as \code{mar.panel}. } \item{panel.begin,panel.end}{ Optional. Functions that will be executed before and after each panel is plotted. See Details. } \item{panel.args}{ Optional. Function that determines different plot arguments for different panels. See Details. } \item{panel.begin.args}{ Optional. List of additional arguments for \code{panel.begin} when it is a function. } \item{panel.end.args}{ Optional. List of additional arguments for \code{panel.end} when it is a function. } \item{panel.vpad}{ Amount of extra vertical space that should be allowed for the title of each panel, if a title will be displayed. Expressed as a fraction of the height of the panel. Applies only when \code{equal.scales=FALSE} (the default) and requires that the height of each panel can be determined. } \item{plotcommand}{ Optional. Character string containing the name of the command that should be executed to plot each panel. } \item{adorn.left,adorn.right,adorn.top,adorn.bottom}{ Optional. Functions that will be executed to generate additional plots at the margins (left, right, top and/or bottom, respectively) of the array of plots. Alternatively they may be objects of class \code{"colourmap"} or \code{"symbolmap"}. } \item{adorn.size}{ Relative width (as a fraction of the other panels' widths) of the margin plots. } \item{adorn.args}{ Optional list of arguments passed to the functions \code{adorn.left}, \code{adorn.right}, \code{adorn.top} and \code{adorn.bottom} if they are functions, or arguments passed to \code{\link{plot.colourmap}} or \code{\link{plot.symbolmap}} as appropriate. } \item{equal.scales}{ Logical value indicating whether the components should be plotted at (approximately) the same physical scale. } \item{halign,valign}{ Logical values indicating whether panels in a column should be aligned to the same \eqn{x} coordinate system (\code{halign=TRUE}) and whether panels in a row should be aligned to the same \eqn{y} coordinate system (\code{valign=TRUE}). These are applicable only if \code{equal.scales=TRUE}. } } \value{ Null. } \details{ This is the \code{plot} method for the class \code{"anylist"}. An object of class \code{"anylist"} represents a list of objects intended to be treated in the same way. This is the method for \code{plot}. In the \pkg{spatstat} package, various functions produce an object of class \code{"anylist"}, essentially a list of objects of the same kind. These objects can be plotted in a nice arrangement using \code{plot.anylist}. See the Examples. The argument \code{panel.args} determines extra graphics parameters for each panel. It should be a function that will be called as \code{panel.args(i)} where \code{i} is the panel number. Its return value should be a list of graphics parameters that can be passed to the relevant \code{plot} method. These parameters override any parameters specified in the \code{\dots} arguments. The arguments \code{panel.begin} and \code{panel.end} determine graphics that will be plotted before and after each panel is plotted. They may be objects of some class that can be plotted with the generic \code{plot} command. Alternatively they may be functions that will be called as \code{panel.begin(i, y, main=main.panel[i])} and \code{panel.end(i, y, add=TRUE)} where \code{i} is the panel number and \code{y = x[[i]]}. If all entries of \code{x} are pixel images, the function \code{\link{image.listof}} is called to control the plotting. The arguments \code{equal.ribbon} and \code{col} can be used to determine the colour map or maps applied. If \code{equal.scales=FALSE} (the default), then the plot panels will have equal height on the plot device (unless there is only one column of panels, in which case they will have equal width on the plot device). This means that the objects are plotted at different physical scales, by default. If \code{equal.scales=TRUE}, then the dimensions of the plot panels on the plot device will be proportional to the spatial dimensions of the corresponding components of \code{x}. This means that the objects will be plotted at \emph{approximately} equal physical scales. If these objects have very different spatial sizes, the plot command could fail (when it tries to plot the smaller objects at a tiny scale), with an error message that the figure margins are too large. The objects will be plotted at \emph{exactly} equal physical scales, and \emph{exactly} aligned on the device, under the following conditions: \itemize{ \item every component of \code{x} is a spatial object whose position can be shifted by \code{\link{shift}}; \item \code{panel.begin} and \code{panel.end} are either \code{NULL} or they are spatial objects whose position can be shifted by \code{\link{shift}}; \item \code{adorn.left}, \code{adorn.right}, \code{adorn.top} and \code{adorn.bottom} are all \code{NULL}. } Another special case is when every component of \code{x} is an object of class \code{"fv"} representing a function. If \code{equal.scales=TRUE} then all these functions will be plotted with the same axis scales (i.e. with the same \code{xlim} and the same \code{ylim}). } \section{Spacing between plots}{ The spacing between individual plots is controlled by the parameters \code{mar.panel}, \code{hsep} and \code{vsep}. If \code{equal.scales=FALSE}, the plot panels are logically separate plots. The margins for each panel are determined by the argument \code{mar.panel} which becomes the graphics parameter \code{mar} described in the help file for \code{\link{par}}. One unit of \code{mar} corresponds to one line of text in the margin. If \code{hsep} or \code{vsep} are present, \code{mar.panel} is augmented by \code{c(vsep, hsep, vsep, hsep)/2}. If \code{equal.scales=TRUE}, all the plot panels are drawn in the same coordinate system which represents a physical scale. The unit of measurement for \code{mar.panel[1,3]} is one-sixth of the greatest height of any object plotted in the same row of panels, and the unit for \code{mar.panel[2,4]} is one-sixth of the greatest width of any object plotted in the same column of panels. If \code{hsep} or \code{vsep} are present, they are interpreted in the same units as \code{mar.panel[2]} and \code{mar.panel[1]} respectively. } \seealso{ \code{\link{contour.listof}}, \code{\link{image.listof}}, \code{\link[spatstat.explore]{density.splitppp}} } \section{Error messages}{ If the error message \sQuote{Figure margins too large} occurs, this generally means that one of the objects had a much smaller physical scale than the others. Ensure that \code{equal.scales=FALSE} and increase the values of \code{mar.panel}. } \examples{ if(require(spatstat.explore)) { trichotomy <- list(regular=cells, random=japanesepines, clustered=redwood) K <- lapply(trichotomy, Kest) K <- as.anylist(K) plot(K, main="") } # list of 3D point patterns ape1 <- osteo[osteo$shortid==4, "pts", drop=TRUE] class(ape1) plot(ape1, main.panel="", mar.panel=0.1, hsep=0.7, vsep=1, cex=1.5, pch=21, bg='white') } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/is.rectangle.Rd0000644000176200001440000000152114611065347016471 0ustar liggesusers\name{is.rectangle} \alias{is.rectangle} \alias{is.polygonal} \alias{is.mask} \title{Determine Type of Window} \description{ Determine whether a window is a rectangle, a polygonal region, or a binary mask. } \usage{ is.rectangle(w) is.polygonal(w) is.mask(w) } \arguments{ \item{w}{ Window to be inspected. An object of class \code{"owin"}. } } \value{ Logical value, equal to \code{TRUE} if \code{w} is a window of the specified type. } \details{ These simple functions determine whether a window \code{w} (object of class \code{"owin"}) is a rectangle (\code{is.rectangle(w) = TRUE}), a domain with polygonal boundary (\code{is.polygonal(w) = TRUE}), or a binary pixel mask (\code{is.mask(w) = TRUE}). } \seealso{ \code{\link{owin}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/colourtools.Rd0000644000176200001440000001506514611065345016505 0ustar liggesusers\name{colourtools} \alias{colourtools} %DoNotExport \alias{paletteindex} \alias{rgb2hex} \alias{rgb2hsva} \alias{col2hex} \alias{paletteindex} \alias{samecolour} \alias{complementarycolour} \alias{interp.colours} \alias{is.colour} \alias{is.grey} \alias{to.grey} \alias{to.opaque} \alias{to.transparent} \alias{to.saturated} \title{ Convert and Compare Colours in Different Formats } \description{ These functions convert between different formats for specifying a colour in \R, determine whether colours are equivalent, and convert colour to greyscale. } \usage{ col2hex(x) rgb2hex(v, maxColorValue=255) rgb2hsva(red, green=NULL, blue=NULL, alpha=NULL, maxColorValue=255) paletteindex(x) samecolour(x,y) complementarycolour(x) interp.colours(x, length.out=512) is.colour(x) to.grey(x, weights=c(0.299, 0.587, 0.114), transparent=FALSE) is.grey(x) to.opaque(x) to.transparent(x, fraction) to.saturated(x, s=1) } \arguments{ \item{x,y}{ Any valid specification for a colour or sequence of colours accepted by \code{\link[grDevices]{col2rgb}}. } \item{v}{ A numeric vector of length 3, giving the RGB values of a single colour, or a 3-column matrix giving the RGB values of several colours. Alternatively a vector of length 4 or a matrix with 4 columns, giving the RGB and alpha (transparency) values. } \item{red,green,blue,alpha}{ Arguments acceptable to \code{\link[grDevices]{rgb}} determining the red, green, blue channels and optionally the alpha (transparency) channel. Note that \code{red} can also be a matrix with 3 \bold{rows} giving the RGB values, or a matrix with 4 rows giving RGB and alpha values. } \item{maxColorValue}{ Number giving the maximum possible value for the entries in \code{v} or \code{red,green,blue,alpha}. } \item{weights}{ Numeric vector of length 3 giving relative weights for the red, green, and blue channels respectively. } \item{transparent}{ Logical value indicating whether transparent colours should be converted to transparent grey values (\code{transparent=TRUE}) or converted to opaque grey values (\code{transparent=FALSE}, the default). } \item{fraction}{ Transparency fraction. Numerical value or vector of values between 0 and 1, giving the opaqueness of a colour. A fully opaque colour has \code{fraction=1}. } \item{length.out}{ Integer. Length of desired sequence. } \item{s}{ Saturation value (between 0 and 1). } } \details{ \code{is.colour(x)} can be applied to any kind of data \code{x} and returns \code{TRUE} if \code{x} can be interpreted as a colour or colours. The remaining functions expect data that can be interpreted as colours. \code{col2hex} converts colours specified in any format into their hexadecimal character codes. \code{rgb2hex} converts RGB colour values into their hexadecimal character codes. It is a very minor extension to \code{\link[grDevices]{rgb}}. Arguments to \code{rgb2hex} should be similar to arguments to \code{\link[grDevices]{rgb}}. \code{rgb2hsva} converts RGB colour values into HSV colour values including the alpha (transparency) channel. It is an extension of \code{\link[grDevices]{rgb2hsv}}. Arguments to \code{rgb2hsva} should be similar to arguments to \code{\link[grDevices]{rgb2hsv}}. \code{paletteindex} checks whether the colour or colours specified by \code{x} are available in the default palette returned by \code{\link[grDevices]{palette}()}. If so, it returns the index or indices of the colours in the palette. If not, it returns \code{NA}. \code{samecolour} decides whether two colours \code{x} and \code{y} are equivalent. \code{is.grey} determines whether each entry of \code{x} is a greyscale colour, and returns a logical vector. \code{to.grey} converts the colour data in \code{x} to greyscale colours. Alternatively \code{x} can be an object of class \code{"colourmap"} and \code{to.grey(x)} is the modified colour map. \code{to.opaque} converts the colours in \code{x} to opaque (non-transparent) colours, and \code{to.transparent} converts them to transparent colours with a specified transparency value. Note that \code{to.transparent(x,1)} is equivalent to \code{to.opaque(x)}. For \code{to.grey}, \code{to.opaque} and \code{to.transparent}, if all the data in \code{x} specifies colours from the standard palette, and if the result would be equivalent to \code{x}, then the result is identical to \code{x}. \code{to.saturated} converts each colour in \code{x} to its fully-saturated equivalent. For example, pink is mapped to red. Shades of grey are converted to black; white is unchanged. \code{complementarycolour} replaces each colour by its complementary colour in RGB space (the colour obtained by replacing RGB values \code{(r, g, b)} by \code{(255-r, 255-g, 255-b)}). The transparency value is not changed. Alternatively \code{x} can be an object of class \code{"colourmap"} and \code{complementarycolour(x)} is the modified colour map. \code{interp.colours} interpolates between each successive pair of colours in a sequence of colours, to generate a more finely-spaced sequence. It uses linear interpolation in HSV space (with hue represented as a two-dimensional unit vector). } \section{Warning}{ \code{paletteindex("green")} returns \code{NA} because the green colour in the default palette is called \code{"green3"}. } \value{ For \code{col2hex} and \code{rgb2hex} a character vector containing hexadecimal colour codes. For \code{to.grey}, \code{to.opaque} and \code{to.transparent}, either a character vector containing hexadecimal colour codes, or a value identical to the input \code{x}. For \code{rgb2hsva}, a matrix with 3 or 4 rows containing HSV colour values. For \code{paletteindex}, an integer vector, possibly containing \code{NA} values. For \code{samecolour} and \code{is.grey}, a logical value or logical vector. } \author{\adrian and \rolf } \seealso{ \code{\link[grDevices]{col2rgb}}, \code{\link[grDevices]{rgb2hsv}}, \code{\link[grDevices]{palette}}. See also the class of colour map objects in the \pkg{spatstat} package: \code{\link{colourmap}}, \code{\link{interp.colourmap}}, \code{\link{tweak.colourmap}}. } \examples{ samecolour("grey", "gray") paletteindex("grey") col2hex("orange") to.grey("orange") to.saturated("orange") complementarycolour("orange") is.grey("lightgrey") is.grey(8) to.transparent("orange", 0.5) to.opaque("red") interp.colours(c("orange", "red", "violet"), 5) } \keyword{color} spatstat.geom/man/print.ppp.Rd0000644000176200001440000000141314611065350016037 0ustar liggesusers\name{print.ppp} \alias{print.ppp} \title{Print Brief Details of a Point Pattern Dataset} \description{ Prints a very brief description of a point pattern dataset. } \usage{ \method{print}{ppp}(x, \dots) } \arguments{ \item{x}{Point pattern (object of class \code{"ppp"}).} \item{\dots}{Ignored.} } \details{ A very brief description of the point pattern \code{x} is printed. This is a method for the generic function \code{\link{print}}. } \seealso{ \code{\link{print}}, \code{\link{print.owin}}, \code{\link{summary.ppp}} } \examples{ cells # plain vanilla point pattern lansing # multitype point pattern longleaf # numeric marks demopat # weird polygonal window } \author{\adrian and \rolf } \keyword{spatial} \keyword{print} spatstat.geom/man/nearestValue.Rd0000644000176200001440000000243214611065347016553 0ustar liggesusers\name{nearestValue} \alias{nearestValue} \title{ Image of Nearest Defined Pixel Value } \description{ Given a pixel image defined on a subset of a rectangle, this function assigns a value to every pixel in the rectangle, by looking up the value of the nearest pixel that has a value. } \usage{ nearestValue(X) } \arguments{ \item{X}{ A pixel image (object of class \code{"im"}). } } \details{ A pixel image in \pkg{spatstat} is always stored on a rectangular grid of pixels, but its value may be \code{NA} on some pixels, indicating that the image is not defined at those pixels. This function assigns a value to every pixel in the rectangular grid. For each pixel \code{a} in the grid, if the value of \code{X} is not defined at \code{a}, the function finds the nearest other pixel \code{b} at which the value of \code{X} is defined, and takes the pixel value at \code{b} as the new pixel value at \code{a}. } \value{ Another image of the same kind as \code{X}. } \author{ \adrian. } \seealso{ \code{\link[spatstat.explore]{blur}}, \code{\link[spatstat.explore]{Smooth.ppp}} } \examples{ X <- as.im(function(x,y) { x + y }, letterR) Y <- nearestValue(X) plot(solist("X"=X,"nearestValue(X)"=Y), main="", panel.end=letterR) } \keyword{spatial} \keyword{manip} spatstat.geom/man/compatible.im.Rd0000644000176200001440000000212414611065345016634 0ustar liggesusers\name{compatible.im} \alias{compatible.im} \title{Test Whether Pixel Images Are Compatible} \description{ Tests whether two or more pixel image objects have compatible dimensions. } \usage{ \method{compatible}{im}(A, B, \dots, tol=1e-6) } \arguments{ \item{A,B,\dots}{Two or more pixel images (objects of class \code{"im"}).} \item{tol}{Tolerance factor} } \details{ This function tests whether the pixel images \code{A} and \code{B} (and any additional images \code{\dots}) have compatible pixel dimensions. They are compatible if they have the same number of rows and columns, the same physical pixel dimensions, and occupy the same rectangle in the plane. The argument \code{tol} specifies the maximum tolerated error in the pixel coordinates, expressed as a fraction of the dimensions of a single pixel. } \value{ Logical value: \code{TRUE} if the images are compatible, and \code{FALSE} if they are not. } \seealso{ \code{\link{eval.im}}, \code{\link{harmonise.im}}, \code{\link{commonGrid}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/pixelcentres.Rd0000644000176200001440000000240714643111575016624 0ustar liggesusers\name{pixelcentres} \alias{pixelcentres} \title{ Extract Pixel Centres as Point Pattern } \description{ Given a pixel image or binary mask window, extract the centres of all pixels and return them as a point pattern. } \usage{ pixelcentres(X, W = NULL, ...) } \arguments{ \item{X}{ Pixel image (object of class \code{"im"}) or window (object of class \code{"owin"}). } \item{W}{ Optional window to contain the resulting point pattern. } \item{\dots}{ Optional arguments defining the pixel resolution. } } \details{ If the argument \code{X} is a pixel image, the result is a point pattern, consisting of the centre of every pixel whose pixel value is not \code{NA}. If \code{X} is a window which is a binary mask, the result is a point pattern consisting of the centre of every pixel inside the window (i.e. every pixel for which the mask value is \code{TRUE}). Otherwise, \code{X} is first converted to a window, then converted to a mask using \code{\link[spatstat.geom]{as.mask}}, then handled as above. } \value{ A point pattern (object of class \code{"ppp"}). } \seealso{ \code{\link{raster.xy}} } \examples{ pixelcentres(letterR, dimyx=5) } \author{\adrian , \rolf and \ege } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.box3.Rd0000644000176200001440000000227014611065345015370 0ustar liggesusers\name{as.box3} \Rdversion{1.1} \alias{as.box3} \title{ Convert Data to Three-Dimensional Box } \description{ Interprets data as the dimensions of a three-dimensional box. } \usage{ as.box3(...) } \arguments{ \item{\dots}{ Data that can be interpreted as giving the dimensions of a three-dimensional box. See Details. } } \details{ This function converts data in various formats to an object of class \code{"box3"} representing a three-dimensional box (see \code{\link{box3}}). The arguments \code{\dots} may be \itemize{ \item an object of class \code{"box3"} \item arguments acceptable to \code{box3} \item a numeric vector of length 6, interpreted as \code{c(xrange[1],xrange[2],yrange[1],yrange[2],zrange[1],zrange[2])} \item an object of class \code{"pp3"} representing a three-dimensional point pattern contained in a box. } } \value{ Object of class \code{"box3"}. } \author{\adrian and \rolf } \seealso{ \code{\link{box3}}, \code{\link{pp3}} } \examples{ X <- c(0,10,0,10,0,5) as.box3(X) X <- pp3(runif(42),runif(42),runif(42), box3(c(0,1))) as.box3(X) } \keyword{spatial} \keyword{manip} \concept{Three-dimensional} spatstat.geom/man/has.close.Rd0000644000176200001440000000406114611065346015773 0ustar liggesusers\name{has.close} \alias{has.close} \alias{has.close.default} \alias{has.close.ppp} \alias{has.close.pp3} \title{ Check Whether Points Have Close Neighbours } \description{ For each point in a point pattern, determine whether the point has a close neighbour in the same pattern. } \usage{ has.close(X, r, Y=NULL, \dots) \method{has.close}{default}(X,r, Y=NULL, \dots, periodic=FALSE) \method{has.close}{ppp}(X,r, Y=NULL, \dots, periodic=FALSE, sorted=FALSE) \method{has.close}{pp3}(X,r, Y=NULL, \dots, periodic=FALSE, sorted=FALSE) } \arguments{ \item{X,Y}{ Point patterns of class \code{"ppp"} or \code{"pp3"} or \code{"lpp"}. } \item{r}{ Threshold distance: a number greater than zero. } \item{periodic}{ Logical value indicating whether to measure distances in the periodic sense, so that opposite sides of the (rectangular) window are treated as identical. } \item{sorted}{ Logical value, indicating whether the points of \code{X} (and \code{Y}, if given) are already sorted into increasing order of the \eqn{x} coordinates. } \item{\dots}{Other arguments are ignored.} } \details{ This is simply a faster version of \code{(nndist(X) <= r)} or \code{(nncross(X,Y,what="dist") <= r)}. \code{has.close(X,r)} determines, for each point in the pattern \code{X}, whether or not this point has a neighbour in the same pattern \code{X} which lies at a distance less than or equal to \code{r}. \code{has.close(X,r,Y)} determines, for each point in the pattern \code{X}, whether or not this point has a neighbour in the \emph{other} pattern \code{Y} which lies at a distance less than or equal to \code{r}. The function \code{has.close} is generic, with methods for \code{"ppp"} and \code{"pp3"} and a default method. } \value{ A logical vector, with one entry for each point of \code{X}. } \author{ \adrian. } \seealso{ \code{\link{nndist}} } \examples{ has.close(redwood, 0.05) with(split(amacrine), has.close(on, 0.05, off)) with(osteo, sum(has.close(pts, 20))) } \keyword{spatial} \keyword{math} spatstat.geom/man/rescale.im.Rd0000644000176200001440000000343614611065350016136 0ustar liggesusers\name{rescale.im} \alias{rescale.im} \title{Convert Pixel Image to Another Unit of Length} \description{ Converts a pixel image to another unit of length. } \usage{ \method{rescale}{im}(X, s, unitname) } \arguments{ \item{X}{Pixel image (object of class \code{"im"}).} \item{s}{Conversion factor: the new units are \code{s} times the old units.} \item{unitname}{ Optional. New name for the unit of length. See \code{\link{unitname}}. } } \value{ Another pixel image (of class \code{"im"}), containing the same pixel values, but with pixel coordinates expressed in the new units. } \details{ This is a method for the generic function \code{\link{rescale}}. The spatial coordinates of the pixels in \code{X} will be re-expressed in terms of a new unit of length that is \code{s} times the current unit of length given in \code{X}. (Thus, the coordinate values are \emph{divided} by \code{s}, while the unit value is multiplied by \code{s}). If \code{s} is missing, then the coordinates will be re-expressed in \sQuote{native} units; for example if the current unit is equal to 0.1 metres, then the coordinates will be re-expressed in metres. The result is a pixel image representing the \emph{same} data but re-expressed in a different unit. Pixel values are unchanged. This may not be what you intended! } \seealso{ \code{\link{im}}, \code{\link{rescale}}, \code{\link{unitname}}, \code{\link{eval.im}} } \examples{ # Bramble Canes data: 1 unit = 9 metres bramblecanes # distance transform Z <- distmap(bramblecanes) # convert to metres # first alter the pixel values Zm <- eval.im(9 * Z) # now rescale the pixel coordinates Z <- rescale(Zm, 1/9) # or equivalently Z <- rescale(Zm) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/marks.Rd0000644000176200001440000000652014611065347015234 0ustar liggesusers\name{marks} \alias{marks} \alias{marks.ppp} \alias{marks.ppx} \alias{marks<-} \alias{marks<-.ppp} \alias{marks<-.ppx} \alias{setmarks} \alias{\%mark\%} %DoNotExport %NAMESPACE export("%mark%") \title{Marks of a Point Pattern} \description{ Extract or change the marks attached to a point pattern dataset. } \usage{ marks(x, \dots) \method{marks}{ppp}(x, \dots, dfok=TRUE, drop=TRUE) \method{marks}{ppx}(x, \dots, drop=TRUE) marks(x, \dots) <- value \method{marks}{ppp}(x, \dots, dfok=TRUE, drop=TRUE) <- value \method{marks}{ppx}(x, \dots) <- value setmarks(x, value) x \%mark\% value } \arguments{ \item{x}{ Point pattern dataset (object of class \code{"ppp"} or \code{"ppx"}). } \item{\dots}{ Ignored. } \item{dfok}{ Logical. If \code{FALSE}, data frames of marks are not permitted and will generate an error. } \item{drop}{ Logical. If \code{TRUE}, a data frame consisting of a single column of marks will be converted to a vector or factor. } \item{value}{ Replacement value. A vector, data frame or hyperframe of mark values, or \code{NULL}. } } \value{ For \code{marks(x)}, the result is a vector, factor, data frame or hyperframe, containing the mark values attached to the points of \code{x}. For \code{marks(x) <- value}, the result is the updated point pattern \code{x} (with the side-effect that the dataset \code{x} is updated in the current environment). For \code{setmarks(x,value)} and \code{x \%mark\% value}, the return value is the point pattern obtained by replacing the marks of \code{x} by \code{value}. } \details{ These functions extract or change the marks attached to the points of the point pattern \code{x}. The expression \code{marks(x)} extracts the marks of \code{x}. The assignment \code{marks(x) <- value} assigns new marks to the dataset \code{x}, and updates the dataset \code{x} in the current environment. The expression \code{setmarks(x,value)} or equivalently \code{x \%mark\% value} returns a point pattern obtained by replacing the marks of \code{x} by \code{value}, but does not change the dataset \code{x} itself. For point patterns in two-dimensional space (objects of class \code{"ppp"}) the marks can be a vector, a factor, or a data frame. For general point patterns (objects of class "ppx") the marks can be a vector, a factor, a data frame or a hyperframe. For the assignment \code{marks(x) <- value}, the \code{value} should be a vector or factor of length equal to the number of points in \code{x}, or a data frame or hyperframe with as many rows as there are points in \code{x}. If \code{value} is a single value, or a data frame or hyperframe with one row, then it will be replicated so that the same marks will be attached to each point. To remove marks, use \code{marks(x) <- NULL} or \code{\link{unmark}(x)}. Use \code{\link{ppp}} or \code{\link{ppx}} to create point patterns in more general situations. } \seealso{ \code{\link{ppp.object}}, \code{\link{ppx}}, \code{\link{unmark}}, \code{\link{hyperframe}} } \examples{ X <- amacrine # extract marks m <- marks(X) # recode the mark values "off", "on" as 0, 1 marks(X) <- as.integer(m == "on") } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/pixellate.ppp.Rd0000644000176200001440000001173314643111575016706 0ustar liggesusers\name{pixellate.ppp} \alias{pixellate.ppp} \alias{as.im.ppp} \title{Convert Point Pattern to Pixel Image} \description{ Converts a point pattern to a pixel image. The value in each pixel is the number of points falling in that pixel, and is typically either 0 or 1. } \usage{ \method{pixellate}{ppp}(x, W=NULL, \dots, weights = NULL, padzero=FALSE, fractional=FALSE, preserve=FALSE, DivideByPixelArea=FALSE, savemap=FALSE) \method{as.im}{ppp}(X, \dots) } \arguments{ \item{x,X}{Point pattern (object of class \code{"ppp"}).} \item{\dots}{Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution} \item{W}{Optional window mask (object of class \code{"owin"}) determining the pixel raster. } \item{weights}{Optional vector of weights associated with the points.} \item{padzero}{ Logical value indicating whether to set pixel values to zero outside the window. } \item{fractional,preserve}{ Logical values determining the type of discretisation. See Details. } \item{DivideByPixelArea}{ Logical value, indicating whether the resulting pixel values should be divided by the pixel area. } \item{savemap}{ Logical value, indicating whether to save information about the discretised coordinates of the points of \code{x}. } } \details{ The functions \code{pixellate.ppp} and \code{as.im.ppp} convert a spatial point pattern \code{x} into a pixel image, by counting the number of points (or the total weight of points) falling in each pixel. Calling \code{as.im.ppp} is equivalent to calling \code{pixellate.ppp} with its default arguments. Note that \code{pixellate.ppp} is more general than \code{as.im.ppp} (it has additional arguments for greater flexibility). The functions \code{as.im.ppp} and \code{pixellate.ppp} are methods for the generic functions \code{\link{as.im}} and \code{\link{pixellate}} respectively, for the class of point patterns. The pixel raster (in which points are counted) is determined by the argument \code{W} if it is present (for \code{pixellate.ppp} only). In this case \code{W} should be a binary mask (a window object of class \code{"owin"} with type \code{"mask"}). Otherwise the pixel raster is determined by extracting the window containing \code{x} and converting it to a binary pixel mask using \code{\link[spatstat.geom]{as.mask}}. The arguments \code{\dots} are passed to \code{\link[spatstat.geom]{as.mask}} to control the pixel resolution. If \code{weights} is \code{NULL}, then for each pixel in the mask, the algorithm counts how many points in \code{x} fall in the pixel. This count is usually either 0 (for a pixel with no data points in it) or 1 (for a pixel containing one data point) but may be greater than 1. The result is an image with these counts as its pixel values. If \code{weights} is given, it should be a numeric vector of the same length as the number of points in \code{x}. For each pixel, the algorithm finds the total weight associated with points in \code{x} that fall in the given pixel. The result is an image with these total weights as its pixel values. By default (if \code{zeropad=FALSE}) the resulting pixel image has the same spatial domain as the window of the point pattern \code{x}. If \code{zeropad=TRUE} then the resulting pixel image has a rectangular domain; pixels outside the original window are assigned the value zero. The discretisation procedure is controlled by the arguments \code{fractional} and \code{preserve}. \itemize{ \item The argument \code{fractional} specifies how data points are mapped to pixels. If \code{fractional=FALSE} (the default), each data point is allocated to the nearest pixel centre. If \code{fractional=TRUE}, each data point is allocated with fractional weight to four pixel centres (the corners of a rectangle containing the data point). \item The argument \code{preserve} specifies what to do with pixels lying near the boundary of the window, if the window is not a rectangle. If \code{preserve=FALSE} (the default), any contributions that are attributed to pixel centres lying outside the window are reset to zero. If \code{preserve=TRUE}, any such contributions are shifted to the nearest pixel lying inside the window, so that the total mass is preserved. } If \code{savemap=TRUE} then the result has an attribute \code{"map"} which is a 2-column matrix containing the row and column indices of the discretised positions of the points of \code{x} in the pixel grid. } \value{ A pixel image (object of class \code{"im"}). } \seealso{ \code{\link{pixellate}}, \code{\link{im}}, \code{\link{as.im}}, \code{\link[spatstat.explore]{density.ppp}}, \code{\link[spatstat.explore]{Smooth.ppp}}. } \examples{ plot(pixellate(humberside)) plot(pixellate(humberside, fractional=TRUE)) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/spatstat.geom-deprecated.Rd0000644000176200001440000000161114650323103020770 0ustar liggesusers\name{spatstat.geom-deprecated} \alias{spatstat.geom-deprecated} %DoNotExport \alias{as.psp.owin} \alias{circumradius} \alias{circumradius.owin} \alias{circumradius.ppp} \title{Deprecated spatstat.geom functions} \description{ Deprecated spatstat.geom functions. } \usage{ \method{as.psp}{owin}(x, \dots, window=NULL, check=spatstat.options("checksegments"), fatal=TRUE) circumradius(x, \dots) \method{circumradius}{owin}(x, \dots) \method{circumradius}{ppp}(x, \dots) } \details{ These functions are deprecated, and will eventually be deleted from the \pkg{spatstat.geom} package. \code{as.psp.owin} has been replaced by \code{\link{edges}}. \code{circumradius} is replaced by the more appropriately named \code{boundingradius}. } \value{ \code{as.psp.owin} returns a window (object of class \code{"owin"}). \code{circumradius} returns a numeric value. } \keyword{internal} spatstat.geom/man/Extract.hyperframe.Rd0000644000176200001440000001143314611065346017670 0ustar liggesusers\name{Extract.hyperframe} \alias{[.hyperframe} \alias{[<-.hyperframe} \alias{$.hyperframe} \alias{$<-.hyperframe} \alias{[[.hyperframe} \alias{[[<-.hyperframe} \title{Extract or Replace Subset of Hyperframe} \description{ Extract or replace a subset of a hyperframe. } \usage{ \method{[}{hyperframe}(x, i, j, drop, strip=drop, \dots) \method{[}{hyperframe}(x, i, j) <- value \method{$}{hyperframe}(x, name) \method{$}{hyperframe}(x, name) <- value \method{[[}{hyperframe}(x, \dots) \method{[[}{hyperframe}(x, i, j) <- value } \arguments{ \item{x}{ A hyperframe (object of class \code{"hyperframe"}). } \item{i,j}{ Row and column indices. } \item{drop,strip}{ Logical values indicating what to do when the hyperframe has only one row or column. See Details. } \item{\dots}{ Indices specifying elements to extract by \code{[[.hyperframe}. Ignored by \code{[.hyperframe}. } \item{name}{ Name of a column of the hyperframe. } \item{value}{ Replacement value for the subset. A hyperframe or (if the subset is a single column) a list or an atomic vector. } } \value{ A hyperframe (of class \code{"hyperframe"}). } \details{ These functions extract a designated subset of a hyperframe, or replace the designated subset with another hyperframe. The function \code{[.hyperframe} is a method for the subset operator \code{\link{[}} for the class \code{"hyperframe"}. It extracts the subset of \code{x} specified by the row index \code{i} and column index \code{j}. The argument \code{drop} determines whether the array structure will be discarded if possible. The argument \code{strip} determines whether the list structure in a row or column or cell will be discarded if possible. If \code{drop=FALSE} (the default), the return value is always a hyperframe or data frame. If \code{drop=TRUE}, and if the selected subset has only one row, or only one column, or both, then \itemize{ \item{ if \code{strip=FALSE}, the result is a list, with one entry for each array cell that was selected. } \item{ if \code{strip=TRUE}, \itemize{ \item if the subset has one row containing several columns, the result is a list or (if possible) an atomic vector; \item if the subset has one column containing several rows, the result is a list or (if possible) an atomic vector; \item if the subset has exactly one row and exactly one column, the result is the object (or atomic value) contained in this row and column. } } } The function \code{[<-.hyperframe} is a method for the subset replacement operator \code{\link{[<-}} for the class \code{"hyperframe"}. It replaces the designated subset with the hyperframe \code{value}. The subset of \code{x} to be replaced is designated by the arguments \code{i} and \code{j} as above. The replacement \code{value} should be a hyperframe with the appropriate dimensions, or (if the specified subset is a single column) a list of the appropriate length. The function \code{$.hyperframe} is a method for \code{\link{$}} for hyperframes. It extracts the relevant column of the hyperframe. The result is always a list (i.e. equivalent to using \code{[.hyperframe} with \code{strip=FALSE}). The function \code{$<-.hyperframe} is a method for \code{\link{$<-}} for hyperframes. It replaces the relevant column of the hyperframe. The replacement value should be a list of the appropriate length. The functions \code{[[.hyperframe} and \code{[[<-.hyperframe} are methods for \code{\link{[[}} and \code{[[<-.hyperframe} for hyperframes. They are analogous to \code{\link{[[.data.frame}} and \code{[[<-.data.frame} in that they can be used in different ways: \itemize{ \item when \code{[[.hyperframe} or \code{[[<-.hyperframe} are used with a single index, as in \code{x[[n]]} or \code{x[[n]] <- value}, they index the hyperframe as if it were a list, extracting or replacing a column of the hyperframe. \item when \code{[[.hyperframe} or \code{[[<-.hyperframe} are used with two indices, as in \code{x[[i,j]]} or \code{x[[i,j]] <- value}, they index the hyperframe as if it were a matrix, and can only be used to extract or replace one element. } } \seealso{ \code{\link{hyperframe}} } \examples{ h <- hyperframe(X=list(square(1), square(2)), Y=list(sin, cos)) h h[1, ] h[1, ,drop=TRUE] h[ , 1] h[ , 1, drop=TRUE] h[1,1] h[1,1,drop=TRUE] h[1,1,drop=TRUE,strip=FALSE] h[1,1] <- list(square(3)) # extract column h$X # replace existing column h$Y <- list(cells, cells) # add new column h$Z <- list(tan, exp) # h[["Y"]] h[[2,1]] h[[2,1]] <- square(3) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/whichhalfplane.Rd0000644000176200001440000000202014611065351017056 0ustar liggesusers\name{whichhalfplane} \alias{whichhalfplane} \title{ Test Which Side of Infinite Line a Point Falls On } \description{ Given an infinite line and a spatial point location, determine which side of the line the point falls on. } \usage{ whichhalfplane(L, x, y = NULL) } \arguments{ \item{L}{ Object of class \code{"infline"} specifying one or more infinite straight lines in two dimensions. } \item{x,y}{ Arguments acceptable to \code{\link[grDevices]{xy.coords}} specifying the locations of the points. } } \details{ An infinite line \eqn{L} divides the two-dimensional plane into two half-planes. This function returns a matrix \code{M} of logical values in which \code{M[i,j] = TRUE} if the \code{j}th spatial point lies below or to the left of the \code{i}th line. } \value{ A logical matrix. } \author{ \adrian. } \seealso{ \code{\link{infline}} } \examples{ L <- infline(p=runif(3), theta=runif(3, max=2*pi)) X <- runifrect(4) whichhalfplane(L, X) } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.owin.Rd0000644000176200001440000001751514611065345015501 0ustar liggesusers\name{as.owin} \alias{as.owin} \alias{as.owin.default} \alias{as.owin.owin} \alias{as.owin.ppp} \alias{as.owin.psp} \alias{as.owin.quad} \alias{as.owin.quadratcount} \alias{as.owin.tess} \alias{as.owin.im} \alias{as.owin.layered} \alias{as.owin.data.frame} \alias{as.owin.distfun} \alias{as.owin.nnfun} \alias{as.owin.funxy} \alias{as.owin.boxx} \title{Convert Data To Class owin} \description{ Converts data specifying an observation window in any of several formats, into an object of class \code{"owin"}. } \usage{ as.owin(W, \dots, fatal=TRUE) \method{as.owin}{default}(W, \dots, fatal=TRUE) \method{as.owin}{owin}(W, \dots, fatal=TRUE) \method{as.owin}{ppp}(W, \dots, fatal=TRUE) \method{as.owin}{psp}(W, \dots, fatal=TRUE) \method{as.owin}{quad}(W, \dots, fatal=TRUE) \method{as.owin}{quadratcount}(W, \dots, fatal=TRUE) \method{as.owin}{tess}(W, \dots, fatal=TRUE) \method{as.owin}{im}(W, \dots, fatal=TRUE) \method{as.owin}{layered}(W, \dots, fatal=TRUE) \method{as.owin}{data.frame}(W, \dots, step, fatal=TRUE) \method{as.owin}{distfun}(W, \dots, fatal=TRUE) \method{as.owin}{nnfun}(W, \dots, fatal=TRUE) \method{as.owin}{funxy}(W, \dots, fatal=TRUE) \method{as.owin}{boxx}(W, \dots, fatal=TRUE) } \arguments{ \item{W}{ Data specifying an observation window, in any of several formats described under \emph{Details} below. } \item{fatal}{ Logical value determining what to do if the data cannot be converted to an observation window. See Details. } \item{\dots}{Ignored.} \item{step}{ Optional. A single number, or numeric vector of length 2, giving the grid step lengths in the \eqn{x} and \eqn{y} directions. } } \value{ An object of class \code{"owin"} (see \code{\link{owin.object}}) specifying an observation window. } \details{ The class \code{"owin"} is a way of specifying the observation window for a point pattern. See \code{\link{owin.object}} for an overview. The generic function \code{as.owin} converts data in any of several formats into an object of class \code{"owin"} for use by the \pkg{spatstat} package. The function \code{as.owin} is generic, with methods for different classes of objects, and a default method. The argument \code{W} may be \itemize{ \item an object of class \code{"owin"} \item a structure with entries \code{xrange}, \code{yrange} specifying the \eqn{x} and \eqn{y} dimensions of a rectangle \item a structure with entries named \code{xmin}, \code{xmax}, \code{ymin}, \code{ymax} (in any order) specifying the \eqn{x} and \eqn{y} dimensions of a rectangle. This will accept objects of class \code{bbox} in the \code{sf} package. \item a numeric vector of length 4 (interpreted as \code{(xmin, xmax, ymin, ymax)} in that order) specifying the \eqn{x} and \eqn{y} dimensions of a rectangle \item a structure with entries named \code{xl}, \code{xu}, \code{yl}, \code{yu} (in any order) specifying the \eqn{x} and \eqn{y} dimensions of a rectangle as \code{(xmin, xmax) = (xl, xu)} and \code{(ymin, ymax) = (yl, yu)}. This will accept objects of class \code{spp} used in the Venables and Ripley \pkg{spatial} package. \item an object of class \code{"ppp"} representing a point pattern. In this case, the object's \code{window} structure will be extracted. \item an object of class \code{"psp"} representing a line segment pattern. In this case, the object's \code{window} structure will be extracted. \item an object of class \code{"tess"} representing a tessellation. In this case, the object's \code{window} structure will be extracted. \item an object of class \code{"quad"} representing a quadrature scheme. In this case, the window of the \code{data} component will be extracted. \item an object of class \code{"im"} representing a pixel image. In this case, a window of type \code{"mask"} will be returned, with the same pixel raster coordinates as the image. An image pixel value of \code{NA}, signifying that the pixel lies outside the window, is transformed into the logical value \code{FALSE}, which is the corresponding convention for window masks. \item an object of class \code{"ppm"}, \code{"kppm"}, \code{"slrm"} or \code{"dppm"} representing a fitted point process model. In this case, if \code{from="data"} (the default), \code{as.owin} extracts the original point pattern data to which the model was fitted, and returns the observation window of this point pattern. If \code{from="covariates"} then \code{as.owin} extracts the covariate images to which the model was fitted, and returns a binary mask window that specifies the pixel locations. \item an object of class \code{"lpp"} representing a point pattern on a linear network. In this case, \code{as.owin} extracts the linear network and returns a window containing this network. \item an object of class \code{"lppm"} representing a fitted point process model on a linear network. In this case, \code{as.owin} extracts the linear network and returns a window containing this network. \item A \code{data.frame} with exactly three columns. Each row of the data frame corresponds to one pixel. Each row contains the \eqn{x} and \eqn{y} coordinates of a pixel, and a logical value indicating whether the pixel lies inside the window. \item A \code{data.frame} with exactly two columns. Each row of the data frame contains the \eqn{x} and \eqn{y} coordinates of a pixel that lies inside the window. \item an object of class \code{"distfun"}, \code{"nnfun"} or \code{"funxy"} representing a function of spatial location, defined on a spatial domain. The spatial domain of the function will be extracted. \item an object of class \code{"rmhmodel"} representing a point process model that can be simulated using \code{\link[spatstat.random]{rmh}}. The window (spatial domain) of the model will be extracted. The window may be \code{NULL} in some circumstances (indicating that the simulation window has not yet been determined). This is not treated as an error, because the argument \code{fatal} defaults to \code{FALSE} for this method. \item an object of class \code{"layered"} representing a list of spatial objects. See \code{\link{layered}}. In this case, \code{as.owin} will be applied to each of the objects in the list, and the union of these windows will be returned. \item an object of another suitable class from another package. For full details, see \code{vignette('shapefiles')}. } If the argument \code{W} is not in one of these formats and cannot be converted to a window, then an error will be generated (if \code{fatal=TRUE}) or a value of \code{NULL} will be returned (if \code{fatal=FALSE}). When \code{W} is a data frame, the argument \code{step} can be used to specify the pixel grid spacing; otherwise, the spacing will be guessed from the data. } \seealso{ \code{\link[spatstat.model]{as.owin.ppm}}, \code{\link[spatstat.random]{as.owin.rmhmodel}}, \code{\link[spatstat.linnet]{as.owin.lpp}}. \code{\link{owin.object}}, \code{\link{owin}}. Additional methods for \code{as.owin} may be provided by other packages outside the \pkg{spatstat} family. } \examples{ w <- as.owin(c(0,1,0,1)) w <- as.owin(list(xrange=c(0,5),yrange=c(0,10))) # point pattern w <- as.owin(demopat) # image Z <- as.im(function(x,y) { x + 3}, unit.square()) w <- as.owin(Z) # Venables & Ripley 'spatial' package spatialpath <- system.file(package="spatial") if(nchar(spatialpath) > 0) { require(spatial) towns <- ppinit("towns.dat") w <- as.owin(towns) detach(package:spatial) } } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/summary.splitppp.Rd0000644000176200001440000000167414611065350017465 0ustar liggesusers\name{summary.splitppp} \alias{summary.splitppp} \title{Summary of a Split Point Pattern} \description{ Prints a useful summary of a split point pattern. } \usage{ \method{summary}{splitppp}(object, \dots) } \arguments{ \item{object}{ Split point pattern (object of class \code{"splitppp"}, effectively a list of point patterns, usually created by \code{\link{split.ppp}}). } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link{summary}}. An object of the class \code{"splitppp"} is effectively a list of point patterns (objects of class \code{"ppp"}) representing different sub-patterns of an original point pattern. This function extracts a useful summary of each of the sub-patterns. } \seealso{ \code{\link{summary}}, \code{\link{split}}, \code{\link{split.ppp}} } \examples{ summary(split(amacrine)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/affine.ppp.Rd0000644000176200001440000000314214611065345016140 0ustar liggesusers\name{affine.ppp} \alias{affine.ppp} \title{Apply Affine Transformation To Point Pattern} \description{ Applies any affine transformation of the plane (linear transformation plus vector shift) to a point pattern. } \usage{ \method{affine}{ppp}(X, mat=diag(c(1,1)), vec=c(0,0), \dots) } \arguments{ \item{X}{Point pattern (object of class \code{"ppp"}).} \item{mat}{Matrix representing a linear transformation.} \item{vec}{Vector of length 2 representing a translation.} \item{\dots}{Arguments passed to \code{\link{affine.owin}} affecting the handling of the observation window, if it is a binary pixel mask. } } \value{ Another point pattern (of class \code{"ppp"}) representing the result of applying the affine transformation. } \details{ The point pattern, and its window, are subjected first to the linear transformation represented by \code{mat} (multiplying on the left by \code{mat}), and are then translated by the vector \code{vec}. The argument \code{mat} must be a nonsingular \eqn{2 \times 2}{2 * 2} matrix. This is a method for the generic function \code{\link{affine}}. } \seealso{ \code{\link{affine}}, \code{\link{affine.owin}}, \code{\link{affine.psp}}, \code{\link{affine.im}}, \code{\link{flipxy}}, \code{\link{rotate}}, \code{\link{shift}} } \examples{ # shear transformation X <- affine(cells, matrix(c(1,0,0.6,1),ncol=2)) if(interactive()) { plot(X) # rescale y coordinates by factor 1.3 plot(affine(cells, diag(c(1,1.3)))) } } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} \concept{Geometrical transformations} spatstat.geom/man/as.data.frame.hyperframe.Rd0000644000176200001440000000275114611065345020664 0ustar liggesusers\name{as.data.frame.hyperframe} \alias{as.data.frame.hyperframe} \title{Coerce Hyperframe to Data Frame} \description{ Converts a hyperframe to a data frame. } \usage{ \method{as.data.frame}{hyperframe}(x, row.names = NULL, optional = FALSE, ..., discard=TRUE, warn=TRUE) } \arguments{ \item{x}{Hyperframe (object of class \code{"hyperframe"}).} \item{row.names}{Optional character vector of row names.} \item{optional}{Argument passed to \code{\link{as.data.frame}} controlling what happens to row names.} \item{\dots}{Ignored.} \item{discard}{Logical. Whether to discard columns of the hyperframe that do not contain atomic data. See Details. } \item{warn}{Logical. Whether to issue a warning when columns are discarded.} } \details{ This is a method for the generic function \code{\link{as.data.frame}} for the class of hyperframes (see \code{\link{hyperframe}}. If \code{discard=TRUE}, any columns of the hyperframe that do not contain atomic data will be removed (and a warning will be issued if \code{warn=TRUE}). If \code{discard=FALSE}, then such columns are converted to strings indicating what class of data they originally contained. } \value{ A data frame. } \examples{ h <- hyperframe(X=1:3, Y=letters[1:3], f=list(sin, cos, tan)) as.data.frame(h, discard=TRUE, warn=FALSE) as.data.frame(h, discard=FALSE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/raster.x.Rd0000644000176200001440000000500014643111575015655 0ustar liggesusers\name{raster.x} \alias{raster.x} \alias{raster.y} \alias{raster.xy} \title{Cartesian Coordinates for a Pixel Raster} \description{ Return the \eqn{x} and \eqn{y} coordinates of each pixel in a pixel image or binary mask. } \usage{ raster.x(w, drop=FALSE) raster.y(w, drop=FALSE) raster.xy(w, drop=FALSE) } \arguments{ \item{w}{ A pixel image (object of class \code{"im"}) or a mask window (object of class \code{"owin"} of type \code{"mask"}). } \item{drop}{ Logical. If \code{TRUE}, then coordinates of pixels that lie outside the window are removed. If \code{FALSE} (the default) then the coordinates of every pixel in the containing rectangle are retained. } } \value{ \code{raster.xy} returns a list with components \code{x} and \code{y} which are numeric vectors of equal length containing the pixel coordinates. If \code{drop=FALSE}, \code{raster.x} and \code{raster.y} return a matrix of the same dimensions as the pixel grid in \code{w}, and giving the value of the \eqn{x} (or \eqn{y}) coordinate of each pixel in the raster. If \code{drop=TRUE}, \code{raster.x} and \code{raster.y} return numeric vectors. } \details{ The argument \code{w} should be either a pixel image (object of class \code{"im"}) or a mask window (an object of class \code{"owin"} of type \code{"mask"}). If \code{drop=FALSE} (the default), the functions \code{raster.x} and \code{raster.y} return a matrix of the same dimensions as the pixel image or mask itself, with entries giving the \eqn{x} coordinate (for \code{raster.x}) or \eqn{y} coordinate (for \code{raster.y}) of each pixel in the pixel grid. If \code{drop=TRUE}, pixels that lie outside the window \code{w} (or outside the domain of the image \code{w}) are removed, and \code{raster.x} and \code{raster.y} return numeric vectors containing the coordinates of the pixels that are inside the window \code{w}. The function \code{raster.xy} returns a list with components \code{x} and \code{y} which are numeric vectors of equal length containing the pixel coordinates. } \seealso{ \code{\link{owin}}, \code{\link[spatstat.geom]{as.mask}}, \code{\link{pixelcentres}} } \examples{ u <- owin(c(-1,1),c(-1,1)) # square of side 2 w <- as.mask(u, eps=0.01) # 200 x 200 grid X <- raster.x(w) Y <- raster.y(w) disc <- owin(c(-1,1), c(-1,1), mask=(X^2 + Y^2 <= 1)) # plot(disc) # approximation to the unit disc } \author{\adrian , \rolf and \ege } \keyword{spatial} \keyword{manip} spatstat.geom/man/default.image.colours.Rd0000644000176200001440000000322514716551163020312 0ustar liggesusers\name{default.image.colours} \alias{default.image.colours} \alias{reset.default.image.colours} \title{ Default Colours for Images in Spatstat } \description{ Extract or change the default colours for images in \pkg{spatstat}. } \usage{ default.image.colours() reset.default.image.colours(col = NULL) } \arguments{ \item{col}{ A vector of colour values. } } \details{ These functions extract and change the current default colours used for plotting colour images in the \pkg{spatstat} family of packages, in particular by the functions \code{\link[spatstat.geom]{plot.im}} and \code{\link[spatstat.linnet]{plot.linim}}. The default colour values are a vector of character strings which can be interpreted as colours. In any particular instance of \code{\link[spatstat.geom]{plot.im}} or \code{\link[spatstat.linnet]{plot.linim}}, the default colours are interpolated to obtain a vector of colour values of the required length (usually 256, controlled by the argument \code{ncolours} to the plot command). \code{default.image.colours()} returns the current default colours. \code{reset.default.image.colours(col)} sets the default colours to be the vector \code{col}. \code{reset.default.image.colours()} or \code{reset.default.image.colours(NULL)} resets the factory default, which is row 29 of the Kovesi uniform perceptual contrast table described in \code{\link[spatstat.data]{Kovesi}}. } \value{ A character vector of values which can be interpreted as colours. } \author{ \adrian. } \seealso{ \code{\link[spatstat.geom]{plot.im}} } \examples{ a <- default.image.colours() length(a) } \keyword{color} \keyword{hplot} spatstat.geom/man/summary.listof.Rd0000644000176200001440000000150314611065350017101 0ustar liggesusers\name{summary.listof} \alias{summary.listof} \title{Summary of a List of Things} \description{ Prints a useful summary of each item in a list of things. } \usage{ \method{summary}{listof}(object, \dots) } \arguments{ \item{object}{ An object of class \code{"listof"}. } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link{summary}}. An object of the class \code{"listof"} is effectively a list of things which are all of the same class. This function extracts a useful summary of each of the items in the list. } \seealso{ \code{\link{summary}}, \code{\link{plot.listof}} } \examples{ x <- list(A=runif(10), B=runif(10), C=runif(10)) class(x) <- c("listof", class(x)) summary(x) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/quantess.Rd0000644000176200001440000001072714611065350015760 0ustar liggesusers\name{quantess} \alias{quantess} \alias{quantess.owin} \alias{quantess.ppp} \alias{quantess.im} \title{Quantile Tessellation} \description{ Divide space into tiles which contain equal amounts of stuff. } \usage{ quantess(M, Z, n, \dots) \method{quantess}{owin}(M, Z, n, \dots, type=2, origin=c(0,0), eps=NULL) \method{quantess}{ppp}(M, Z, n, \dots, type=2, origin=c(0,0), eps=NULL) \method{quantess}{im}(M, Z, n, \dots, type=2, origin=c(0,0)) } \arguments{ \item{M}{ A spatial object (such as a window, point pattern or pixel image) determining the weight or amount of stuff at each location. } \item{Z}{ A spatial covariate (a pixel image or a \code{function(x,y)}) or one of the strings \code{"x"} or \code{"y"} indicating the Cartesian coordinates \eqn{x} or \eqn{y}, or one of the strings \code{"rad"} or \code{"ang"} indicating polar coordinates. The range of values of \code{Z} will be broken into \code{n} bands containing equal amounts of stuff. } \item{n}{ Number of bands. A positive integer. } \item{type}{ Integer specifying the rule for calculating quantiles. Passed to \code{\link[stats]{quantile.default}}. } \item{\dots}{ Additional arguments passed to \code{\link{quadrats}} or \code{\link{tess}} defining another tessellation which should be intersected with the quantile tessellation. } \item{origin}{ Location of the origin of polar coordinates, if \code{Z="rad"} or \code{Z="ang"}. Either a numeric vector of length 2 giving the location, or a point pattern containing only one point, or a list with two entries named \code{x} and \code{y}, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). } \item{eps}{ Optional. The size of pixels in the approximation which is used to compute the quantiles. A positive numeric value, or vector of two positive numeric values. } } \details{ A \emph{quantile tessellation} is a division of space into pieces which contain equal amounts of stuff. The function \code{quantess} computes a quantile tessellation and returns the tessellation itself. The function \code{quantess} is generic, with methods for windows (class \code{"owin"}), point patterns (\code{"ppp"}) and pixel images (\code{"im"}). The first argument \code{M} (for mass) specifies the spatial distribution of stuff that is to be divided. If \code{M} is a window, the \emph{area} of the window is to be divided into \code{n} equal pieces. If \code{M} is a point pattern, the \emph{number of points} in the pattern is to be divided into \code{n} equal parts, as far as possible. If \code{M} is a pixel image, the pixel values are interpreted as weights, and the \emph{total weight} is to be divided into \code{n} equal parts. The second argument \code{Z} is a spatial covariate. The range of values of \code{Z} will be divided into \code{n} bands, each containing the same total weight. That is, we determine the quantiles of \code{Z} with weights given by \code{M}. For convenience, additional arguments \code{\dots} can be given, to further subdivide the tiles of the tessellation. These arguments should be recognised by one of the functions \code{\link{quadrats}} or \code{\link{tess}}. The tessellation determined by these arguments is intersected with the quantile tessellation. The result of \code{quantess} is a tessellation of \code{as.owin(M)} determined by the quantiles of \code{Z}. } \value{ A tessellation (object of class \code{"tess"}). } \author{ Original idea by Ute Hahn. Implemented in \code{spatstat} by \spatstatAuthors. } \seealso{ \code{\link{tess}}, \code{\link{quadrats}}, \code{\link{quantile}}, \code{\link{tilenames}} } \examples{ plot(quantess(letterR, "x", 5)) plot(quantess(bronzefilter, "x", 6)) points(unmark(bronzefilter)) plot(quantess(letterR, "rad", 7, origin=c(2.8, 1.5))) plot(quantess(letterR, "ang", 7, origin=c(2.8, 1.5))) opa <- par(mar=c(0,0,2,5)) A <- quantess(Window(bei), bei.extra$elev, 4) plot(A, ribargs=list(las=1)) B <- quantess(bei, bei.extra$elev, 4) tilenames(B) <- paste(spatstat.utils::ordinal(1:4), "quartile") plot(B, ribargs=list(las=1)) points(bei, pch=".", cex=2, col="white") par(opa) } \keyword{spatial} \keyword{manip} \concept{Tessellation} spatstat.geom/man/as.hyperframe.Rd0000644000176200001440000000501314735371702016661 0ustar liggesusers\name{as.hyperframe} \Rdversion{1.1} \alias{as.hyperframe} \alias{as.hyperframe.default} \alias{as.hyperframe.data.frame} \alias{as.hyperframe.hyperframe} \alias{as.hyperframe.listof} \alias{as.hyperframe.anylist} \title{ Convert Data to Hyperframe } \description{ Converts data from any suitable format into a hyperframe. } \usage{ as.hyperframe(x, \dots) \method{as.hyperframe}{default}(x, \dots) \method{as.hyperframe}{data.frame}(x, \dots, stringsAsFactors=FALSE) \method{as.hyperframe}{hyperframe}(x, \dots) \method{as.hyperframe}{listof}(x, \dots) \method{as.hyperframe}{anylist}(x, \dots) } \arguments{ \item{x}{ Data in some other format. } \item{\dots}{ Optional arguments passed to \code{\link{hyperframe}}. } \item{stringsAsFactors}{ Logical. If \code{TRUE}, any column of the data frame \code{x} that contains character strings will be converted to a \code{factor}. If \code{FALSE}, no such conversion will occur. } } \details{ A hyperframe is like a data frame, except that its entries can be objects of any kind. The generic function \code{as.hyperframe} converts any suitable kind of data into a hyperframe. There are methods for the classes \code{data.frame}, \code{listof}, \code{anylist} and a default method, all of which convert data that is like a hyperframe into a hyperframe object. (The method for the class \code{listof} and \code{anylist} converts a list of objects, of arbitrary type, into a hyperframe with one column.) These methods do not discard any information. There are also methods for other classes (see \code{\link{as.hyperframe.ppx}}) which extract the coordinates from a spatial dataset. These methods do discard some information. } \section{Conversion of Strings to Factors}{ Note that \code{as.hyperframe.default} will convert a character vector to a factor. It behaves like \code{\link{as.data.frame}}. However \code{as.hyperframe.data.frame} does not convert strings to factors; it respects the structure of the data frame \code{x}. The behaviour can be changed using the argument \code{stringsAsFactors}. } \value{ An object of class \code{"hyperframe"} created by \code{\link{hyperframe}}. } \author{\adrian and \rolf.} \seealso{ \code{\link{hyperframe}}, \code{\link{as.hyperframe.ppx}} } \examples{ df <- data.frame(x=runif(4),y=letters[1:4]) as.hyperframe(df) sims <- replicate(3, runifrect(10), simplify=FALSE) as.hyperframe(as.listof(sims)) as.hyperframe(as.solist(sims)) } \keyword{spatial} \keyword{manip} spatstat.geom/man/diameter.box3.Rd0000644000176200001440000000366514611065346016571 0ustar liggesusers\name{diameter.box3} \Rdversion{1.1} \alias{diameter.box3} \alias{volume.box3} \alias{shortside.box3} \alias{sidelengths.box3} \alias{eroded.volumes.box3} \alias{shortside} \alias{sidelengths} \alias{eroded.volumes} \title{ Geometrical Calculations for Three-Dimensional Box } \description{ Calculates the volume, diameter, shortest side, side lengths, or eroded volume of a three-dimensional box. } \usage{ \method{diameter}{box3}(x) \method{volume}{box3}(x) shortside(x) sidelengths(x) eroded.volumes(x, r) \method{shortside}{box3}(x) \method{sidelengths}{box3}(x) \method{eroded.volumes}{box3}(x, r) } \arguments{ \item{x}{ Three-dimensional box (object of class \code{"box3"}). } \item{r}{ Numeric value or vector of numeric values for which eroded volumes should be calculated. } } \details{ \code{diameter.box3} computes the diameter of the box. \code{volume.box3} computes the volume of the box. \code{shortside.box3} finds the shortest of the three side lengths of the box. \code{sidelengths.box3} returns all three side lengths of the box. \code{eroded.volumes} computes, for each entry \code{r[i]}, the volume of the smaller box obtained by removing a slab of thickness \code{r[i]} from each face of the box. This smaller box is the subset consisting of points that lie at least \code{r[i]} units away from the boundary of the box. } \value{ For \code{diameter.box3}, \code{shortside.box3} and \code{volume.box3}, a single numeric value. For \code{sidelengths.box3}, a vector of three numbers. For \code{eroded.volumes}, a numeric vector of the same length as \code{r}. } \author{\adrian and \rolf } \seealso{ \code{\link{as.box3}} } \examples{ X <- box3(c(0,10),c(0,10),c(0,5)) diameter(X) volume(X) sidelengths(X) shortside(X) hd <- shortside(X)/2 eroded.volumes(X, seq(0,hd, length=10)) } \keyword{spatial} \keyword{math} \concept{Three-dimensional} spatstat.geom/man/disc.Rd0000644000176200001440000000527514643111575015047 0ustar liggesusers\name{disc} \alias{disc} \title{Circular Window} \description{ Creates a circular window } \usage{ disc(radius=1, centre=c(0,0), \dots, mask=FALSE, npoly=128, delta=NULL, metric=NULL) } \arguments{ \item{radius}{Radius of the circle.} \item{centre}{The centre of the circle.} \item{mask}{Logical flag controlling the type of approximation to a perfect circle. See Details. } \item{npoly}{Number of edges of the polygonal approximation, if \code{mask=FALSE}. Incompatible with \code{delta}. } \item{delta}{ Tolerance of polygonal approximation: the length of arc that will be replaced by one edge of the polygon. Incompatible with \code{npoly}. } \item{\dots}{Arguments passed to \code{as.mask} determining the pixel resolution, if \code{mask=TRUE}. } \item{metric}{ Optional. A distance metric (object of class \code{"metric"}). The disc with respect to this metric will be computed. } } \value{ An object of class \code{"owin"} (see \code{\link{owin.object}}) specifying a window. } \details{ This command creates a window object representing a disc, with the given radius and centre. By default, the circle is approximated by a polygon with \code{npoly} edges. If \code{mask=TRUE}, then the disc is approximated by a binary pixel mask. The resolution of the mask is controlled by the arguments \code{\dots} which are passed to \code{\link[spatstat.geom]{as.mask}}. The argument \code{radius} must be a single positive number. The argument \code{centre} specifies the disc centre: it can be either a numeric vector of length 2 giving the coordinates, or a \code{list(x,y)} giving the coordinates of exactly one point, or a point pattern (object of class \code{"ppp"}) containing exactly one point. If the argument \code{metric} is given, it should be a distance metric (object of class \code{"metric"}). The disc with respect to this metric will be computed. } \seealso{ \code{\link{ellipse}}, \code{\link{discs}}, \code{\link{owin.object}}, \code{\link{owin}}, \code{\link[spatstat.geom]{as.mask}} } \note{This function can also be used to generate regular polygons, by setting \code{npoly} to a small integer value. For example \code{npoly=5} generates a pentagon and \code{npoly=13} a triskaidecagon. } \examples{ # unit disc W <- disc() # disc of radius 3 centred at x=10, y=5 W <- disc(3, c(10,5)) # plot(disc()) plot(disc(mask=TRUE)) # nice smooth circle plot(disc(npoly=256)) # how to control the resolution of the mask plot(disc(mask=TRUE, dimyx=256)) # check accuracy of approximation area(disc())/pi area(disc(mask=TRUE))/pi } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{datagen} spatstat.geom/man/scalardilate.Rd0000644000176200001440000000503514611065350016541 0ustar liggesusers\name{scalardilate} \alias{scalardilate} \alias{scalardilate.im} \alias{scalardilate.owin} \alias{scalardilate.ppp} \alias{scalardilate.psp} \alias{scalardilate.default} \title{Apply Scalar Dilation} \description{ Applies scalar dilation to a plane geometrical object, such as a point pattern or a window, relative to a specified origin. } \usage{ scalardilate(X, f, \dots) \method{scalardilate}{im}(X, f, \dots, origin=NULL) \method{scalardilate}{owin}(X, f, \dots, origin=NULL) \method{scalardilate}{ppp}(X, f, \dots, origin=NULL) \method{scalardilate}{psp}(X, f, \dots, origin=NULL) \method{scalardilate}{default}(X, f, \dots) } \arguments{ \item{X}{Any suitable dataset representing a two-dimensional object, such as a point pattern (object of class \code{"ppp"}), a window (object of class \code{"owin"}), a pixel image (class \code{"im"}) and so on. } \item{f}{ Scalar dilation factor. A finite number greater than zero. } \item{\dots}{Ignored by the methods.} \item{origin}{ Origin for the scalar dilation. Either a vector of 2 numbers, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). } } \value{ Another object of the same type, representing the result of applying the scalar dilation. } \details{ This command performs scalar dilation of the object \code{X} by the factor \code{f} relative to the origin specified by \code{origin}. The function \code{scalardilate} is generic, with methods for windows (class \code{"owin"}), point patterns (class \code{"ppp"}), pixel images (class \code{"im"}), line segment patterns (class \code{"psp"}) and a default method. If the argument \code{origin} is not given, then every spatial coordinate is multiplied by the factor \code{f}. If \code{origin} is given, then scalar dilation is performed relative to the specified origin. Effectively, \code{X} is shifted so that \code{origin} is moved to \code{c(0,0)}, then scalar dilation is performed, then the result is shifted so that \code{c(0,0)} is moved to \code{origin}. This command is a special case of an affine transformation: see \code{\link{affine}}. } \seealso{ \code{\link{affine}}, \code{\link{shift}} } \examples{ plot(letterR) plot(scalardilate(letterR, 0.7, origin="left"), col="red", add=TRUE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/spokes.Rd0000644000176200001440000000536614611065350015424 0ustar liggesusers\name{spokes} \alias{spokes} \title{Spokes pattern of dummy points} \description{ Generates a pattern of dummy points in a window, given a data point pattern. The dummy points lie on the radii of circles emanating from each data point. } \usage{ spokes(x, y, nrad = 3, nper = 3, fctr = 1.5, Mdefault = 1) } \arguments{ \item{x}{ Vector of \eqn{x} coordinates of data points, or a list with components \code{x} and \code{y}, or a point pattern (an object of class \code{ppp}). } \item{y}{ Vector of \eqn{y} coordinates of data points. Ignored unless \code{x} is a vector. } \item{nrad}{ Number of radii emanating from each data point. } \item{nper}{ Number of dummy points per radius. } \item{fctr}{ Scale factor. Length of largest spoke radius is \code{fctr * M} where \code{M} is the mean nearest neighbour distance for the data points. } \item{Mdefault}{ Value of \code{M} to be used if \code{x} has length 1. } } \value{ If argument \code{x} is a point pattern, a point pattern with window equal to that of \code{x}. Otherwise a list with two components \code{x} and \code{y}. In either case the components \code{x} and \code{y} of the value are numeric vectors giving the coordinates of the dummy points. } \details{ This function is useful in creating dummy points for quadrature schemes (see \code{\link{quadscheme}}). Given the data points, the function creates a collection of \code{nrad * nper * length(x)} dummy points. Around each data point \code{(x[i],y[i])} there are \code{nrad * nper} dummy points, lying on \code{nrad} radii emanating from \code{(x[i],y[i])}, with \code{nper} dummy points equally spaced along each radius. The (equal) spacing of dummy points along each radius is controlled by the factor \code{fctr}. The distance from a data point to the furthest of its associated dummy points is \code{fctr * M} where \code{M} is the mean nearest neighbour distance for the data points. If there is only one data point the nearest neighbour distance is infinite, so the value \code{Mdefault} will be used in place of \code{M}. If \code{x} is a point pattern, then the value returned is also a point pattern, which is clipped to the window of \code{x}. Hence there may be fewer than \code{nrad * nper * length(x)} dummy points in the pattern returned. } \seealso{ \code{\link{quad.object}}, \code{\link{quadscheme}}, \code{\link{inside.owin}}, \code{\link{gridcentres}}, \code{\link{stratrand}} } \examples{ dat <- runifrect(10) dum <- spokes(dat$x, dat$y, 5, 3, 0.7) plot(dum) Q <- quadscheme(dat, dum, method="dirichlet") plot(Q, tiles=TRUE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/perimeter.Rd0000644000176200001440000000217614611065347016116 0ustar liggesusers\name{perimeter} \Rdversion{1.1} \alias{perimeter} \title{ Perimeter Length of Window } \description{ Computes the perimeter length of a window } \usage{ perimeter(w) } \arguments{ \item{w}{ A window (object of class \code{"owin"}) or data that can be converted to a window by \code{\link{as.owin}}. } } \details{ This function computes the perimeter (length of the boundary) of the window \code{w}. If \code{w} is a rectangle or a polygonal window, the perimeter is the sum of the lengths of the edges of \code{w}. If \code{w} is a mask, it is first converted to a polygonal window using \code{\link{as.polygonal}}, then staircase edges are removed using \code{\link{simplify.owin}}, and the perimeter of the resulting polygon is computed. } \value{ A numeric value giving the perimeter length of the window. } \seealso{ \code{\link{area.owin}} \code{\link{diameter.owin}}, \code{\link{owin.object}}, \code{\link{as.owin}} } \examples{ perimeter(square(3)) perimeter(letterR) if(interactive()) print(perimeter(as.mask(letterR))) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/triangulate.owin.Rd0000644000176200001440000000236714611065351017411 0ustar liggesusers\name{triangulate.owin} \alias{triangulate.owin} \title{ Decompose Window into Triangles } \description{ Given a spatial window, this function decomposes the window into disjoint triangles. The result is a tessellation of the window in which each tile is a triangle. } \usage{ triangulate.owin(W) } \arguments{ \item{W}{Window (object of class \code{"owin"}).} } \details{ The window \code{W} will be decomposed into disjoint triangles. The result is a tessellation of \code{W} in which each tile is a triangle. All triangle vertices lie on the boundary of the original polygon. The window is first converted to a polygonal window using \code{\link{as.polygonal}}. The vertices of the polygonal window are extracted, and the Delaunay triangulation of these vertices is computed using \code{\link{delaunay}}. Each Delaunay triangle is intersected with the window: if the result is not a triangle, the triangulation procedure is applied recursively to this smaller polygon. } \value{ Tessellation (object of class \code{"tess"}). } \author{ \spatstatAuthors } \seealso{ \code{\link{tess}}, \code{\link{delaunay}}, \code{\link{as.polygonal}} } \examples{ plot(triangulate.owin(letterR)) } \keyword{spatial} \keyword{manip} spatstat.geom/man/clip.infline.Rd0000644000176200001440000000226014611065345016464 0ustar liggesusers\name{clip.infline} \alias{clip.infline} \title{Intersect Infinite Straight Lines with a Window} \description{ Take the intersection between a set of infinite straight lines and a window, yielding a set of line segments. } \usage{ clip.infline(L, win) } \arguments{ \item{L}{ Object of class \code{"infline"} specifying a set of infinite straight lines in the plane. } \item{win}{ Window (object of class \code{"owin"}). } } \details{ This function computes the intersection between a set of infinite straight lines in the plane (stored in an object \code{L} of class \code{"infline"} created by the function \code{\link{infline}}) and a window \code{win}. The result is a pattern of line segments. Each line segment carries a mark indicating which line it belongs to. } \value{ A line segment pattern (object of class \code{"psp"}) with a single column of marks. } \author{ \adrian and \rolf. } \seealso{ \code{\link{infline}},\code{\link{psp}}. To divide a window into pieces using infinite lines, use \code{\link{chop.tess}}. } \examples{ L <- infline(p=1:3, theta=pi/4) W <- square(4) clip.infline(L, W) } \keyword{spatial} \keyword{math} spatstat.geom/man/is.im.Rd0000644000176200001440000000117314611065346015134 0ustar liggesusers\name{is.im} \alias{is.im} \title{Test Whether An Object Is A Pixel Image} \description{ Tests whether its argument is a pixel image (object of class \code{"im"}). } \usage{ is.im(x) } \arguments{ \item{x}{Any object.} } \details{ This function tests whether the argument \code{x} is a pixel image object of class \code{"im"}. For details of this class, see \code{\link{im.object}}. The object is determined to be an image if it inherits from class \code{"im"}. } \value{ \code{TRUE} if \code{x} is a pixel image, otherwise \code{FALSE}. } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/flipxy.Rd0000644000176200001440000000211614611065346015426 0ustar liggesusers\name{flipxy} \alias{flipxy} \alias{flipxy.owin} \alias{flipxy.ppp} \alias{flipxy.psp} \alias{flipxy.im} \title{Exchange X and Y Coordinates} \description{ Exchanges the \eqn{x} and \eqn{y} coordinates in a spatial dataset. } \usage{ flipxy(X) \method{flipxy}{owin}(X) \method{flipxy}{ppp}(X) \method{flipxy}{psp}(X) \method{flipxy}{im}(X) } \arguments{ \item{X}{Spatial dataset. An object of class \code{"owin"}, \code{"ppp"}, \code{"psp"} or \code{"im"}. } } \value{ Another object of the same type, representing the result of swapping the \eqn{x} and \eqn{y} coordinates. } \details{ This function swaps the \eqn{x} and \eqn{y} coordinates of a spatial dataset. This could also be performed using the command \code{\link{affine}}, but \code{flipxy} is faster. The function \code{\link{flipxy}} is generic, with methods for the classes of objects listed above. } \seealso{ \code{\link{affine}}, \code{\link{reflect}}, \code{\link{rotate}}, \code{\link{shift}} } \examples{ X <- flipxy(cells) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/lengths_psp.Rd0000644000176200001440000000325414611065347016446 0ustar liggesusers\name{lengths_psp} \alias{lengths_psp} \title{Lengths of Line Segments} \description{ Computes the length of each line segment in a line segment pattern. } \usage{ lengths_psp(x, squared=FALSE) } \arguments{ \item{x}{ A line segment pattern (object of class \code{"psp"}). } \item{squared}{ Logical value indicating whether to return the squared lengths (\code{squared=TRUE}) or the lengths themselves (\code{squared=FALSE}, the default). } } \value{ Numeric vector. } \details{ The length of each line segment is computed and the lengths are returned as a numeric vector. Using squared lengths may be more efficient for some purposes, for example, to find the length of the shortest segment, \code{sqrt(min(lengths.psp(x, squared=TRUE)))} is faster than \code{min(lengths.psp(x))}. } \section{Change of name}{ The name of this function has changed from \code{lengths.psp} to \code{lengths_psp}, because the old name \code{lengths.psp} could be misinterpreted as a method for \code{\link[base]{lengths}}. The older function name \code{lengths.psp} is retained temporarily, for consistency with older code and documentation. In future versions of \pkg{spatstat}, the function name \code{lengths.psp} will be removed. The newer function name \code{lengths_psp} should be used. } \seealso{ \code{\link{marks.psp}}, \code{\link{summary.psp}}, \code{\link{midpoints.psp}}, \code{\link{angles.psp}}, \code{\link{endpoints.psp}}, \code{\link{extrapolate.psp}}. } \examples{ a <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) b <- lengths_psp(a) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/distmap.owin.Rd0000644000176200001440000000724614742317357016547 0ustar liggesusers\name{distmap.owin} \alias{distmap.owin} \title{Distance Map of Window} \description{ Computes the distance from each pixel to the nearest point in the given window. } \usage{ \method{distmap}{owin}(X, \dots, discretise=FALSE, invert=FALSE, connect=8, metric=NULL) } \arguments{ \item{X}{ A window (object of class \code{"owin"}). } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to control pixel resolution. } \item{discretise}{ Logical flag controlling the choice of algorithm when \code{X} is a polygonal window. See Details. } \item{invert}{ If \code{TRUE}, compute the distance transform of the complement of the window. } \item{connect}{ Neighbourhood connectivity for the discrete distance transform algorithm. Either 8 or 24. } \item{metric}{ Optional. A distance metric (object of class \code{"metric"}, see \code{\link{metric.object}}) which will be used to compute the distances. } } \value{ A pixel image (object of class \code{"im"}) whose greyscale values are the values of the distance map. The return value has an attribute \code{"bdry"} which is a pixel image. } \details{ The ``distance map'' of a window \eqn{W} is the function \eqn{f} whose value \code{f(u)} is defined for any two-dimensional location \eqn{u} as the shortest distance from \eqn{u} to \eqn{W}. This function computes the distance map of the window \code{X} and returns the distance map as a pixel image. The greyscale value at a pixel \eqn{u} equals the distance from \eqn{u} to the nearest pixel in \code{X}. Additionally, the return value has an attribute \code{"bdry"} which is also a pixel image. The grey values in \code{"bdry"} give the distance from each pixel to the bounding rectangle of the image. If \code{X} is a binary pixel mask, the distance values computed are not the usual Euclidean distances. Instead the distance between two pixels is measured by the length of the shortest path connecting the two pixels. A path is a series of steps between neighbouring pixels (each pixel has 8 neighbours). This is the standard `distance transform' algorithm of image processing (Rosenfeld and Kak, 1968; Borgefors, 1986). If \code{X} is a polygonal window, then exact Euclidean distances will be computed if \code{discretise=FALSE}. If \code{discretise=TRUE} then the window will first be converted to a binary pixel mask and the discrete path distances will be computed. The arguments \code{\dots} are passed to \code{\link[spatstat.geom]{as.mask}} to control the pixel resolution. This function is a method for the generic \code{\link{distmap}}. } \section{Distance values}{ The pixel values in the image \code{distmap(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values in \code{distmap(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{distmap}}, \code{\link{distmap.ppp}}, \code{\link{distmap.psp}} } \examples{ U <- distmap(letterR) if(interactive()) { plot(U) plot(attr(U, "bdry")) } } \references{ Borgefors, G. Distance transformations in digital images. \emph{Computer Vision, Graphics and Image Processing} \bold{34} (1986) 344--371. Rosenfeld, A. and Pfalz, J.L. Distance functions on digital pictures. \emph{Pattern Recognition} \bold{1} (1968) 33-61. } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/layered.Rd0000644000176200001440000000564314611065347015551 0ustar liggesusers\name{layered} \alias{layered} \title{ Create List of Plotting Layers } \description{ Given several objects which are capable of being plotted, create a list containing these objects as if they were successive layers of a plot. The list can then be plotted in different ways. } \usage{ layered(..., plotargs = NULL, LayerList=NULL) } \arguments{ \item{\dots}{ Objects which can be plotted by \code{plot}. } \item{plotargs}{ Default values of the plotting arguments for each of the objects. A list of lists of arguments of the form \code{name=value}. } \item{LayerList}{ A list of objects. Incompatible with \code{\dots}. } } \details{ Layering is a simple mechanism for controlling a high-level plot that is composed of several successive plots, for example, a background and a foreground plot. The layering mechanism makes it easier to issue the plot command, to switch on or off the plotting of each individual layer, to control the plotting arguments that are passed to each layer, and to zoom in. Each individual layer in the plot should be saved as an object that can be plotted using \code{plot}. It will typically belong to some class, which has a method for the generic function \code{plot}. The command \code{layered} simply saves the objects \code{\dots} as a list of class \code{"layered"}. This list can then be plotted by the method \code{\link{plot.layered}}. Thus, you only need to type a single \code{plot} command to produce the multi-layered plot. Individual layers of the plot can be switched on or off, or manipulated, using arguments to \code{\link{plot.layered}}. The argument \code{plotargs} contains default values of the plotting arguments for each layer. It should be a list, with one entry for each object in \code{\dots}. Each entry of \code{plotargs} should be a list of arguments in the form \code{name=value}, which are recognised by the \code{plot} method for the relevant layer. The \code{plotargs} can also include an argument named \code{.plot} specifying (the name of) a function to perform the plotting instead of the generic \code{plot}. The length of \code{plotargs} should either be equal to the number of layers, or equal to 1. In the latter case it will be replicated to the appropriate length. } \value{ A list, belonging to the class \code{"layered"}. There are methods for \code{plot}, \code{"["}, \code{"shift"}, \code{"affine"}, \code{"rotate"} and \code{"rescale"}. } \author{\adrian and \rolf } \seealso{ \code{\link{plot.layered}}, \code{\link{methods.layered}}, \code{\link{as.layered}}, \code{\link{[.layered}}, \code{\link{layerplotargs}}. } \examples{ D <- distmap(cells) L <- layered(D, cells) L L <- layered(D, cells, plotargs=list(list(ribbon=FALSE), list(pch=16))) plot(L) layerplotargs(L)[[1]] <- list(.plot="contour") plot(L) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/connected.tess.Rd0000644000176200001440000000271214643111575017035 0ustar liggesusers\name{connected.tess} \Rdversion{1.1} \alias{connected.tess} \title{ Connected Components of Tiles of a Tessellation } \description{ Given a tessellation, find the topologically-connected pieces of each tile, and make a new tessellation using these pieces. } \usage{ \method{connected}{tess}(X, \dots) } \arguments{ \item{X}{ A tessellation (object of class \code{"tess"}). } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution. } } \details{ The function \code{connected} is generic. This function \code{connected.tess} is the method for tessellations. Given the tessellation \code{X}, the algorithm considers each tile of the tessellation, and identifies its connected components (topologically-connected pieces) using \code{\link{connected.owin}}. Each of these pieces is treated as a distinct tile and a new tessellation is made from these pieces. The result is another tessellation obtained by subdividing each tile of \code{X} into one or more new tiles. } \value{ Another tessellation (object of class \code{"tess"}). } \seealso{ \code{\link{connected.owin}} } \examples{ BB <- grow.rectangle(Frame(letterR), 0.2) H <- tess(tiles=list(IN=letterR, OUT=complement.owin(letterR, BB))) opa <- par(mfrow=c(1,2)) plot(H, do.col=TRUE) plot(connected(H), do.col=TRUE, col=2:4) par(opa) } \author{ \adrian. } \keyword{spatial} \keyword{math} \concept{Tessellation} spatstat.geom/man/zapsmall.im.Rd0000644000176200001440000000141414611065351016336 0ustar liggesusers\name{zapsmall.im} \alias{zapsmall.im} \title{Rounding of Pixel Values} \description{ Modifies a pixel image, identifying those pixels that have values very close to zero, and replacing the value by zero. } \usage{ zapsmall.im(x, digits) } \arguments{ \item{x}{Pixel image (object of class \code{"im"}).} \item{digits}{ Argument passed to \code{\link{zapsmall}} indicating the precision to be used. } } \details{ The function \code{\link{zapsmall}} is applied to each pixel value of the image \code{x}. } \value{ Another pixel image. } \seealso{ \code{\link{zapsmall}} } \examples{ Z <- as.im(function(x,y) { exp(-40*(x+y)) }, square(1), dimyx=32) zapsmall.im(Z) } \author{\ege and \adrian } \keyword{spatial} \keyword{methods} \keyword{univar} spatstat.geom/man/run.simplepanel.Rd0000644000176200001440000001173614611065350017232 0ustar liggesusers\name{run.simplepanel} \alias{clear.simplepanel} \alias{redraw.simplepanel} \alias{run.simplepanel} \title{ Run Point-and-Click Interface } \description{ Execute various operations in a simple point-and-click user interface. } \usage{ run.simplepanel(P, popup=TRUE, verbose = FALSE) clear.simplepanel(P) redraw.simplepanel(P, verbose = FALSE) } \arguments{ \item{P}{ An interaction panel (object of class \code{"simplepanel"}, created by \code{\link{simplepanel}} or \code{\link{grow.simplepanel}}). } \item{popup}{ Logical. If \code{popup=TRUE} (the default), the panel will be displayed in a new popup window. If \code{popup=FALSE}, the panel will be displayed on the current graphics window if it already exists, and on a new window otherwise. } \item{verbose}{ Logical. If \code{TRUE}, debugging information will be printed. } } \details{ These commands enable the user to run a simple, robust, point-and-click interface to any \R code. The interface is implemented using only the basic graphics package in \R. The argument \code{P} is an object of class \code{"simplepanel"}, created by \code{\link{simplepanel}} or \code{\link{grow.simplepanel}}, which specifies the graphics to be displayed and the actions to be performed when the user interacts with the panel. The command \code{run.simplepanel(P)} activates the panel: the display is initialised and the graphics system waits for the user to click the panel. While the panel is active, the user can only interact with the panel; the \R command line interface and the \R GUI cannot be used. When the panel terminates (typically because the user clicked a button labelled Exit), control returns to the \R command line interface and the \R GUI. The command \code{clear.simplepanel(P)} clears all the display elements in the panel, resulting in a blank display except for the title of the panel. The command \code{redraw.simplepanel(P)} redraws all the buttons of the panel, according to the \code{redraw} functions contained in the panel. If \code{popup=TRUE} (the default), \code{run.simplepanel} begins by calling \code{\link[grDevices]{dev.new}} so that a new popup window is created; this window is closed using \code{\link[grDevices]{dev.off}} when \code{run.simplepanel} terminates. If \code{popup=FALSE}, the panel will be displayed on the current graphics window if it already exists, and on a new window otherwise; this window is not closed when \code{run.simplepanel} terminates. For more sophisticated control of the graphics focus (for example, to use the panel to control the display on another window), initialise the graphics devices yourself using \code{\link[grDevices]{dev.new}} or similar commands; save these devices in the shared environment \code{env} of the panel \code{P}; and write the click/redraw functions of \code{P} in such a way that they access these devices using \code{\link[grDevices]{dev.set}}. Then use \code{run.simplepanel} with \code{popup=FALSE}. } \value{ The return value of \code{run.simplepanel(P)} is the value returned by the \code{exit} function of \code{P}. See \code{\link{simplepanel}}. The functions \code{clear.simplepanel} and \code{redraw.simplepanel} return \code{NULL}. } \author{\adrian and \rolf } \seealso{ \code{\link{simplepanel}} } \examples{ if(interactive()) { # make boxes (alternatively use layout.boxes()) Bminus <- square(1) Bvalue <- shift(Bminus, c(1.2, 0)) Bplus <- shift(Bvalue, c(1.2, 0)) Bdone <- shift(Bplus, c(1.2, 0)) myboxes <- list(Bminus, Bvalue, Bplus, Bdone) myB <- do.call(boundingbox,myboxes) # make environment containing an integer count myenv <- new.env() assign("answer", 0, envir=myenv) # what to do when finished: return the count. myexit <- function(e) { return(get("answer", envir=e)) } # button clicks # decrement the count Cminus <- function(e, xy) { ans <- get("answer", envir=e) assign("answer", ans - 1, envir=e) return(TRUE) } # display the count (clicking does nothing) Cvalue <- function(...) { TRUE } # increment the count Cplus <- function(e, xy) { ans <- get("answer", envir=e) assign("answer", ans + 1, envir=e) return(TRUE) } # quit button Cdone <- function(e, xy) { return(FALSE) } myclicks <- list("-"=Cminus, value=Cvalue, "+"=Cplus, done=Cdone) # redraw the button that displays the current value of the count Rvalue <- function(button, nam, e) { plot(button, add=TRUE) ans <- get("answer", envir=e) text(centroid.owin(button), labels=ans) return(TRUE) } # make the panel P <- simplepanel("Counter", B=myB, boxes=myboxes, clicks=myclicks, redraws = list(NULL, Rvalue, NULL, NULL), exit=myexit, env=myenv) P run.simplepanel(P) } } \keyword{iplot} \keyword{utilities} spatstat.geom/man/psp.object.Rd0000644000176200001440000000616714611065350016167 0ustar liggesusers\name{psp.object} \alias{psp.object} %DoNotExport \title{Class of Line Segment Patterns} \description{ A class \code{"psp"} to represent a spatial pattern of line segments in the plane. Includes information about the window in which the pattern was observed. Optionally includes marks. } \details{ An object of this class represents a two-dimensional pattern of line segments. It specifies \itemize{ \item the locations of the line segments (both endpoints) \item the window in which the pattern was observed \item optionally, a ``mark'' attached to each line segment (extra information such as a type label). } If \code{X} is an object of type \code{psp}, it contains the following elements: \tabular{ll}{ \code{ends} \tab data frame with entries \code{x0, y0, x1, y1} \cr \tab giving coordinates of segment endpoints \cr \code{window} \tab window of observation \cr \tab (an object of class \code{\link{owin}}) \cr \code{n} \tab number of line segments \cr \code{marks} \tab optional vector or data frame of marks \cr \code{markformat} \tab character string specifying the format of the \cr \tab marks; \dQuote{none}, \dQuote{vector}, or \dQuote{dataframe} } Users are strongly advised not to manipulate these entries directly. Objects of class \code{"psp"} may be created by the function \code{\link{psp}} and converted from other types of data by the function \code{\link{as.psp}}. Note that you must always specify the window of observation; there is intentionally no default action of ``guessing'' the window dimensions from the line segments alone. Subsets of a line segment pattern may be obtained by the functions \code{\link{[.psp}} and \code{\link{clip.psp}}. Line segment pattern objects can be plotted just by typing \code{plot(X)} which invokes the \code{plot} method for line segment pattern objects, \code{\link{plot.psp}}. See \code{\link{plot.psp}} for further information. There are also methods for \code{summary} and \code{print} for line segment patterns. Use \code{summary(X)} to see a useful description of the data. Utilities for line segment patterns include \code{\link{midpoints.psp}} (to compute the midpoints of each segment), \code{\link{lengths_psp}}, (to compute the length of each segment), \code{\link{angles.psp}}, (to compute the angle of orientation of each segment), and \code{\link{distmap.psp}} to compute the distance map of a line segment pattern. } \seealso{ \code{\link{psp}}, \code{\link{as.psp}}, \code{\link{[.psp}} } \examples{ # creating a <- psp(runif(20),runif(20),runif(20),runif(20), window=owin()) # converting from other formats a <- as.psp(matrix(runif(80), ncol=4), window=owin()) a <- as.psp(data.frame(x0=runif(20), y0=runif(20), x1=runif(20), y1=runif(20)), window=owin()) # clipping w <- owin(c(0.1,0.7), c(0.2, 0.8)) b <- clip.psp(a, w) b <- a[w] # the last two lines are equivalent. } \author{\adrian and \rolf } \keyword{spatial} \keyword{attribute} spatstat.geom/man/closetriples.Rd0000644000176200001440000000162714611065345016630 0ustar liggesusers\name{closetriples} \alias{closetriples} \title{ Close Triples of Points } \description{ Low-level function to find all close triples of points. } \usage{ closetriples(X, rmax) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"} or \code{"pp3"}). } \item{rmax}{ Maximum distance between each pair of points in a triple. } } \details{ This low-level function finds all triples of points in a point pattern in which each pair lies closer than \code{rmax}. } \value{ A data frame with columns \code{i,j,k} giving the indices of the points in each triple, and a column \code{diam} giving the diameter (maximum pairwise distance) in the triple. } \author{ \spatstatAuthors. } \seealso{ \code{\link{closepairs}}, \code{\link[spatstat.explore]{Tstat}}. } \examples{ closetriples(redwoodfull, 0.02) closetriples(redwoodfull, 0.005) } \keyword{spatial} \keyword{math} spatstat.geom/man/eroded.areas.Rd0000644000176200001440000000314714611065346016454 0ustar liggesusers\name{eroded.areas} \alias{eroded.areas} \title{Areas of Morphological Erosions} \description{ Computes the areas of successive morphological erosions of a window. } \usage{ eroded.areas(w, r, subset=NULL) } \arguments{ \item{w}{A window.} \item{r}{Numeric vector of radii at which erosions will be performed.} \item{subset}{ Optional window inside which the areas should be computed. } } \value{ Numeric vector, of the same length as \code{r}, giving the areas of the successive erosions. } \details{ This function computes the areas of the erosions of the window \code{w} by each of the radii \code{r[i]}. The morphological erosion of a set \eqn{W} by a distance \eqn{r > 0} is the subset consisting of all points \eqn{x \in W}{x in W} such that the distance from \eqn{x} to the boundary of \eqn{W} is greater than or equal to \eqn{r}. In other words it is the result of trimming a margin of width \eqn{r} off the set \eqn{W}. The argument \code{r} should be a vector of positive numbers. The argument \code{w} should be a window (an object of class \code{"owin"}, see \code{\link{owin.object}} for details) or can be given in any format acceptable to \code{\link{as.owin}()}. Unless \code{w} is a rectangle, the computation is performed using a pixel raster approximation. To compute the eroded window itself, use \code{\link{erosion}}. } \seealso{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{erosion}} } \examples{ w <- owin(c(0,1),c(0,1)) a <- eroded.areas(w, seq(0.01,0.49,by=0.01)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/covering.Rd0000644000176200001440000000271614643111575015736 0ustar liggesusers\name{covering} \alias{covering} \title{Cover Region with Discs} \description{ Given a spatial region, this function finds an efficient covering of the region using discs of a chosen radius. } \usage{ covering(W, r, \dots, giveup=1000) } \arguments{ \item{W}{ A window (object of class \code{"owin"}). } \item{r}{positive number: the radius of the covering discs.} \item{\dots}{ extra arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution for the calculations. } \item{giveup}{ Maximum number of attempts to place additional discs. } } \value{ A point pattern (object of class \code{"ppp"}) giving the centres of the discs. } \details{ This function finds an efficient covering of the window \code{W} using discs of the given radius \code{r}. The result is a point pattern giving the centres of the discs. The algorithm tries to use as few discs as possible, but is not guaranteed to find the minimal number of discs. It begins by placing a hexagonal grid of points inside \code{W}, then adds further points until every location inside \code{W} lies no more than \code{r} units away from one of the points. } \examples{ rr <- 0.5 X <- covering(letterR, rr) plot(grow.rectangle(Frame(X), rr), type="n", main="") plot(X, pch=16, add=TRUE, col="red") plot(letterR, add=TRUE, lwd=3) plot(X \%mark\% (2*rr), add=TRUE, markscale=1) } \author{ \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/rescale.psp.Rd0000644000176200001440000000373014611065350016330 0ustar liggesusers\name{rescale.psp} \alias{rescale.psp} \title{Convert Line Segment Pattern to Another Unit of Length} \description{ Converts a line segment pattern dataset to another unit of length. } \usage{ \method{rescale}{psp}(X, s, unitname) } \arguments{ \item{X}{Line segment pattern (object of class \code{"psp"}).} \item{s}{Conversion factor: the new units are \code{s} times the old units.} \item{unitname}{ Optional. New name for the unit of length. See \code{\link{unitname}}. } } \value{ Another line segment pattern (of class \code{"psp"}), representing the same data, but expressed in the new units. } \details{ This is a method for the generic function \code{\link{rescale}}. The spatial coordinates in the line segment pattern \code{X} (and its window) will be re-expressed in terms of a new unit of length that is \code{s} times the current unit of length given in \code{X}. (Thus, the coordinate values are \emph{divided} by \code{s}, while the unit value is multiplied by \code{s}). The result is a line segment pattern representing the \emph{same} data but re-expressed in a different unit. Mark values are unchanged. If \code{s} is missing, then the coordinates will be re-expressed in \sQuote{native} units; for example if the current unit is equal to 0.1 metres, then the coordinates will be re-expressed in metres. } \section{Note}{ The result of this operation is equivalent to the original segment pattern. If you want to actually change the coordinates by a linear transformation, producing a segment pattern that is not equivalent to the original one, use \code{\link{affine}}. } \seealso{ \code{\link{units}}, \code{\link{affine}}, \code{\link{rotate}}, \code{\link{shift}} } \examples{ X <- copper$Lines X # data are in km # convert to metres rescale(X, 1/1000) # convert data and rename unit rescale(X, 1/1000, c("metre", "metres")) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/connected.Rd0000644000176200001440000001141114643111575016054 0ustar liggesusers\name{connected} \Rdversion{1.1} \alias{connected} \alias{connected.im} \alias{connected.owin} \title{ Connected components } \description{ Finds the topologically-connected components of a spatial object, such as the connected clumps of pixels in a binary image. } \usage{ connected(X, \dots) \method{connected}{owin}(X, \dots, method="C", connect=8) \method{connected}{im}(X, \dots, background = NA, method="C", connect=8) } \arguments{ \item{X}{ A spatial object such as a pixel image (object of class \code{"im"}) or a window (object of class \code{"owin"}). } \item{background}{ Optional. Treat pixels with this value as being part of the background. } \item{method}{ String indicating the algorithm to be used. Either \code{"C"} or \code{"interpreted"}. See Details. } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution. } \item{connect}{ The connectivity of the pixel grid: either 8 or 4. } } \details{ The function \code{connected} is generic, with methods for pixel images (class \code{"im"}) and windows (class \code{"owin"}) described here. There are also methods for tessellations (\code{\link{connected.tess}}), point patterns (\code{\link{connected.ppp}} and \code{connected.lpp}), and linear networks (\code{connected.linnet}). The functions described here compute the connected component transform (Rosenfeld and Pfalz, 1966) of a binary image or binary mask. The argument \code{X} is first converted into a pixel image with logical values. Then the algorithm identifies the connected components (topologically-connected clumps of pixels) in the foreground. Two pixels belong to the same connected component if they have the value \code{TRUE} and if they are neighbours. This rule is applied repeatedly until it terminates. Then each connected component contains all the pixels that can be reached by stepping from neighbour to neighbour. Pixels are defined to be neighbours if they are physically adjacent to each other. If \code{connect=4}, each pixel has 4 neighbours, lying one step above or below, or one step to the left or right. If \code{connect=8} (the default), each pixel has 8 neighbours, lying one step above or below, or one step to the left or right, or one diagonal step away. (Pixels at the edge of the image have fewer neighbours.) The 8-connected algorithm is the default because it gives better results when the pixel grid is coarse. The 4-connected algorithm is faster and is recommended when the pixel grid is fine. If \code{method="C"}, the computation is performed by a compiled C language implementation of the classical algorithm of Rosenfeld and Pfalz (1966). If \code{method="interpreted"}, the computation is performed by an \R implementation of the algorithm of Park et al (2000). The result is a factor-valued image, with levels that correspond to the connected components. The Examples show how to extract each connected component as a separate window object. } \value{ A pixel image (object of class \code{"im"}) with factor values. The levels of the factor correspond to the connected components. } \references{ Park, J.-M., Looney, C.G. and Chen, H.-C. (2000) Fast connected component labeling algorithm using a divide and conquer technique. Pages 373-376 in S.Y. Shin (ed) \emph{Computers and Their Applications:} Proceedings of the ISCA 15th International Conference on Computers and Their Applications, March 29-31, 2000, New Orleans, Louisiana USA. ISCA 2000, ISBN 1-880843-32-3. Rosenfeld, A. and Pfalz, J.L. (1966) Sequential operations in digital processing. \emph{Journal of the Association for Computing Machinery} \bold{13} 471-494. } \seealso{ \code{\link{connected.ppp}}, \code{\link{connected.tess}}, \code{\link{im.object}}, \code{\link{tess}} } \section{Warnings}{ It may be hard to distinguish different components in the default plot because the colours of nearby components may be very similar. See the Examples for a randomised colour map. The algorithm for \code{method="interpreted"} can be very slow for large images (or images where the connected components include a large number of pixels). } \examples{ d <- distmap(cells, dimyx=256) X <- levelset(d, 0.07) plot(X) Z <- connected(X) plot(Z) # or equivalently Z <- connected(d <= 0.07) # number of components nc <- length(levels(Z)) # plot with randomised colour map plot(Z, col=hsv(h=sample(seq(0,1,length=nc), nc))) # how to extract the components as a list of windows W <- tiles(tess(image=Z)) } \author{ Original \R code by Julian Burgos, University of Washington. Adapted for \pkg{spatstat} by \adrian and \rolf. } \keyword{spatial} \keyword{math} spatstat.geom/man/sidelengths.owin.Rd0000644000176200001440000000304314611065350017372 0ustar liggesusers\name{sidelengths.owin} \alias{sidelengths.owin} \alias{shortside.owin} \title{Side Lengths of Enclosing Rectangle of a Window} \description{ Computes the side lengths of the (enclosing rectangle of) a window. } \usage{ \method{sidelengths}{owin}(x) \method{shortside}{owin}(x) } \arguments{ \item{x}{ A window whose side lengths will be computed. Object of class \code{"owin"}. } } \value{ For \code{sidelengths.owin}, a numeric vector of length 2 giving the side-lengths (\eqn{x} then \eqn{y}) of the enclosing rectangle. For \code{shortside.owin}, a numeric value. } \details{ The functions \code{shortside} and \code{sidelengths} are generic. The functions documented here are the methods for the class \code{"owin"}. \code{sidelengths.owin} computes the side-lengths of the enclosing rectangle of the window \code{x}. For safety, both functions give a warning if the window is not a rectangle. To suppress the warning, first convert the window to a rectangle using \code{\link{as.rectangle}}. \code{shortside.owin} computes the minimum of the two side-lengths. } \seealso{ \code{\link{shortside}}, \code{\link{sidelengths}} for the generic functions. \code{\link{area.owin}}, \code{\link{diameter.owin}}, \code{\link{perimeter}} for other geometric calculations on \code{"owin"} objects. \code{\link{owin}}, \code{\link{as.owin}}. } \examples{ w <- owin(c(0,2),c(-1,3)) sidelengths(w) shortside(as.rectangle(letterR)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/nnmap.Rd0000644000176200001440000001127514643111575015233 0ustar liggesusers\name{nnmap} \alias{nnmap} \title{ K-th Nearest Point Map } \description{ Given a point pattern, this function constructs pixel images giving the distance from each pixel to its \eqn{k}-th nearest neighbour in the point pattern, and the index of the \eqn{k}-th nearest neighbour. } \usage{ nnmap(X, k = 1, what = c("dist", "which"), \dots, W = as.owin(X), is.sorted.X = FALSE, sortby = c("range", "var", "x", "y")) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"}). } \item{k}{ Integer, or integer vector. The algorithm will find the \code{k}th nearest neighbour. } \item{what}{ Character string specifying what information should be returned. Either the nearest neighbour distance (\code{"dist"}), the index of the nearest neighbour (\code{"which"}), or both. } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution of the result. } \item{W}{ Window (object of class \code{"owin"}) specifying the spatial domain in which the distances will be computed. Defaults to the window of \code{X}. } \item{is.sorted.X}{ Logical value attesting whether the point pattern \code{X} has been sorted. See Details. } \item{sortby}{ Determines which coordinate to use to sort the point pattern. See Details. } } \details{ Given a point pattern \code{X}, this function constructs two pixel images: \itemize{ \item a distance map giving, for each pixel, the distance to the nearest point of \code{X}; \item a nearest neighbour map giving, for each pixel, the identifier of the nearest point of \code{X}. } If the argument \code{k} is specified, then the \code{k}-th nearest neighbours will be found. If \code{what="dist"} then only the distance map is returned. If \code{what="which"} then only the nearest neighbour map is returned. The argument \code{k} may be an integer or an integer vector. If it is a single integer, then the \code{k}-th nearest neighbours are computed. If it is a vector, then the \code{k[i]}-th nearest neighbours are computed for each entry \code{k[i]}. For example, setting \code{k=1:3} will compute the nearest, second-nearest and third-nearest neighbours. } \section{Sorting data and pre-sorted data}{ Read this section if you care about the speed of computation. For efficiency, the algorithm sorts the point pattern \code{X} into increasing order of the \eqn{x} coordinate or increasing order of the the \eqn{y} coordinate. Sorting is only an intermediate step; it does not affect the output, which is always given in the same order as the original data. By default (if \code{sortby="range"}), the sorting will occur on the coordinate that has the larger range of values (according to the frame of the enclosing window of \code{X}). If \code{sortby = "var"}), sorting will occur on the coordinate that has the greater variance (in the pattern \code{X}). Setting \code{sortby="x"} or \code{sortby = "y"} will specify that sorting should occur on the \eqn{x} or \eqn{y} coordinate, respectively. If the point pattern \code{X} is already sorted, then the argument \code{is.sorted.X} should be set to \code{TRUE}, and \code{sortby} should be set equal to \code{"x"} or \code{"y"} to indicate which coordinate is sorted. } \section{Warning About Ties}{ Ties are possible: there may be two data points which lie exactly the same distance away from a particular pixel. This affects the results from \code{nnmap(what="which")}. The handling of ties is not well-defined: it is not consistent between different computers and different installations of \R. If there are ties, then different calls to \code{nnmap(what="which")} may give inconsistent results. For example, you may get a different answer from \code{nnmap(what="which",k=1)} and \code{nnmap(what="which", k=1:2)[[1]]}. } \value{ A pixel image, or a list of pixel images. By default (if \code{what=c("dist", "which")}), the result is a list with two components \code{dist} and \code{which} containing the distance map and the nearest neighbour map. If \code{what="dist"} then the result is a real-valued pixel image containing the distance map. If \code{what="which"} then the result is an integer-valued pixel image containing the nearest neighbour map. If \code{k} is a vector of several integers, then the result is similar except that each pixel image is replaced by a list of pixel images, one for each entry of \code{k}. } \seealso{ \code{\link{distmap}} } \examples{ plot(nnmap(cells, 2, what="which")) } \author{ \adrian , \rolf , and Jens Oehlschlaegel } \keyword{spatial} \keyword{math} spatstat.geom/man/symbolmap.Rd0000644000176200001440000001237714611065351016124 0ustar liggesusers\name{symbolmap} \alias{symbolmap} \title{ Graphics Symbol Map } \description{ Create a graphics symbol map that associates data values with graphical symbols. } \usage{ symbolmap(\dots, range = NULL, inputs = NULL) } \arguments{ \item{\dots}{ Named arguments specifying the graphical parameters. See Details. } \item{range}{ Optional. Range of numbers that are mapped. A numeric vector of length 2 giving the minimum and maximum values that will be mapped. Incompatible with \code{inputs}. } \item{inputs}{ Optional. A vector containing all the data values that will be mapped to symbols. Incompatible with \code{range}. } } \details{ A graphical symbol map is an association between data values and graphical symbols. The command \code{symbolmap} creates an object of class \code{"symbolmap"} that represents a graphical symbol map. Once a symbol map has been created, it can be applied to any suitable data to generate a plot of those data. This makes it easy to ensure that the \emph{same} symbol map is used in two different plots. The symbol map can be plotted as a legend to the plots, and can also be plotted in its own right. The possible values of data that will be mapped are specified by \code{range} or \code{inputs}. \itemize{ \item if \code{range} is given, it should be a numeric vector of length 2 giving the minimum and maximum values of the range of numbers that will be mapped. These limits must be finite. \item if \code{inputs} is given, it should be a vector of any atomic type (e.g. numeric, character, logical, factor). This vector contains all the possible data values that will be mapped. \item If neither \code{range} nor \code{inputs} is given, it is assumed that the possible values are real numbers. } The association of data values with graphical symbols is specified by the other arguments \code{\dots} which are given in \code{name=value} form. These arguments specify the kinds of symbols that will be used, the sizes of the symbols, and graphics parameters for drawing the symbols. Each graphics parameter can be either a single value, for example \code{shape="circles"}, or a \code{function(x)} which determines the value of the graphics parameter as a function of the data \code{x}, for example \code{shape=function(x) ifelse(x > 0, "circles", "squares")}. Colourmaps (see \code{\link{colourmap}}) are also acceptable because they are functions. Currently recognised graphics parameters, and their allowed values, are: \describe{ \item{shape}{ The shape of the symbol: currently either \code{"circles"}, \code{"squares"}, \code{"arrows"}, \code{"crossticks"} or \code{NA}. This parameter takes precedence over \code{pch}. (Crossticks are used only for point patterns on a linear network). } \item{size}{ The size of the symbol: a positive number or zero. } \item{pch}{ Graphics character code: a positive integer, or a single character. See \code{\link[graphics]{par}}. } \item{cex}{ Graphics character expansion factor. } \item{cols}{ Colour of plotting characters. } \item{fg,bg}{ Colour of foreground (or symbol border) and background (or symbol interior). } \item{col,lwd,lty}{ Colour, width and style of lines. } \item{etch}{ Logical. If \code{TRUE}, each symbol is surrounded by a border drawn in the opposite colour, which improves its visibility against the background. Default is \code{FALSE}. } \item{direction,headlength,headangle,arrowtype}{ Numeric parameters of arrow symbols, applicable when \code{shape="arrows"}. Here \code{direction} is the direction of the arrow in degrees anticlockwise from the \eqn{x} axis; \code{headlength} is the length of the head of the arrow in coordinate units; \code{headangle} is the angle subtended by the point of the arrow; and \code{arrowtype} is an integer code specifying which ends of the shaft have arrowheads attached (0 means no arrowheads, 1 is an arrowhead at the start of the shaft, 2 is an arrowhead at the end of the shaft, and 3 is arrowheads at both ends). } } A vector of colour values is also acceptable for the arguments \code{col,cols,fg,bg} if \code{range} is specified. } \value{ An object of class \code{"symbolmap"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{plot.symbolmap}} to plot the symbol map itself. \code{\link{invoke.symbolmap}} to apply the symbol map to some data and plot the resulting symbols. \code{\link{update.symbolmap}} to change the symbol map. There are methods for \code{print} and \code{summary} for symbol maps. } \examples{ g <- symbolmap(inputs=letters[1:10], pch=11:20) g1 <- symbolmap(range=c(0,100), size=function(x) x/50) g2 <- symbolmap(shape=function(x) ifelse(x > 0, "circles", "squares"), size=function(x) sqrt(ifelse(x > 0, x/pi, -x)), bg = function(x) ifelse(abs(x) < 1, "red", "black")) colmap <- colourmap(topo.colors(20), range=c(0,10)) g3 <- symbolmap(pch=21, bg=colmap, range=c(0,10)) plot(g3) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/psp.Rd0000644000176200001440000000756214611065350014722 0ustar liggesusers\name{psp} \alias{psp} \title{Create a Line Segment Pattern} \description{ Creates an object of class \code{"psp"} representing a line segment pattern in the two-dimensional plane. } \usage{ psp(x0,y0, x1, y1, window, marks=NULL, check=spatstat.options("checksegments")) } \arguments{ \item{x0}{Vector of \eqn{x} coordinates of first endpoint of each segment} \item{y0}{Vector of \eqn{y} coordinates of first endpoint of each segment} \item{x1}{Vector of \eqn{x} coordinates of second endpoint of each segment} \item{y1}{Vector of \eqn{y} coordinates of second endpoint of each segment} \item{window}{window of observation, an object of class \code{"owin"}} \item{marks}{(optional) vector or data frame of mark values} \item{check}{Logical value indicating whether to check that the line segments lie inside the window.} } \value{ An object of class \code{"psp"} describing a line segment pattern in the two-dimensional plane (see \code{\link{psp.object}}). } \details{ In the \pkg{spatstat} library, a spatial pattern of line segments is described by an object of class \code{"psp"}. This function creates such objects. The vectors \code{x0}, \code{y0}, \code{x1} and \code{y1} must be numeric vectors of equal length. They are interpreted as the cartesian coordinates of the endpoints of the line segments. A line segment pattern is assumed to have been observed within a specific region of the plane called the observation window. An object of class \code{"psp"} representing a point pattern contains information specifying the observation window. This window must always be specified when creating a point pattern dataset; there is intentionally no default action of ``guessing'' the window dimensions from the data points alone. The argument \code{window} must be an object of class \code{"owin"}. It is a full description of the window geometry, and could have been obtained from \code{\link{owin}} or \code{\link{as.owin}}, or by just extracting the observation window of another dataset, or by manipulating such windows. See \code{\link{owin}} or the Examples below. The optional argument \code{marks} is given if the line segment pattern is marked, i.e. if each line segment carries additional information. For example, line segments which are classified into two or more different types, or colours, may be regarded as having a mark which identifies which colour they are. The object \code{marks} must be a vector of the same length as \code{x0}, or a data frame with number of rows equal to the length of \code{x0}. The interpretation is that \code{marks[i]} or \code{marks[i,]} is the mark attached to the \eqn{i}th line segment. If the marks are real numbers then \code{marks} should be a numeric vector, while if the marks takes only a finite number of possible values (e.g. colours or types) then \code{marks} should be a \code{factor}. See \code{\link{psp.object}} for a description of the class \code{"psp"}. Users would normally invoke \code{psp} to create a line segment pattern, and the function \code{\link{as.psp}} to convert data in another format into a line segment pattern. } \seealso{ \code{\link{psp.object}}, \code{\link{as.psp}}, \code{\link{owin.object}}, \code{\link{owin}}, \code{\link{as.owin}}. Function for extracting information from a segment pattern: \code{\link{marks.psp}}, \code{\link{summary.psp}}, \code{\link{midpoints.psp}}, \code{\link{lengths_psp}} \code{\link{angles.psp}}, \code{\link{endpoints.psp}} Convert line segments to infinite lines: \code{\link{extrapolate.psp}}. } \examples{ X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) m <- data.frame(A=1:10, B=letters[1:10]) X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin(), marks=m) } \author{\adrian and \rolf. } \keyword{spatial} \keyword{datagen} spatstat.geom/man/ppp.object.Rd0000644000176200001440000001012614611065350016152 0ustar liggesusers\name{ppp.object} \alias{ppp.object} %DoNotExport \title{Class of Point Patterns} \description{ A class \code{"ppp"} to represent a two-dimensional point pattern. Includes information about the window in which the pattern was observed. Optionally includes marks. } \details{ This class represents a two-dimensional point pattern dataset. It specifies \itemize{ \item the locations of the points \item the window in which the pattern was observed \item optionally, ``marks'' attached to each point (extra information such as a type label). } If \code{X} is an object of type \code{ppp}, it contains the following elements: \tabular{ll}{ \code{x} \tab vector of \eqn{x} coordinates of data points \cr \code{y} \tab vector of \eqn{y} coordinates of data points \cr \code{n} \tab number of points \cr \code{window} \tab window of observation \cr \tab (an object of class \code{\link{owin}}) \cr \code{marks} \tab optional vector or data frame of marks } Users are strongly advised not to manipulate these entries directly. Objects of class \code{"ppp"} may be created by the function \code{\link{ppp}} and converted from other types of data by the function \code{\link{as.ppp}}. Note that you must always specify the window of observation; there is intentionally no default action of ``guessing'' the window dimensions from the data points alone. Standard point pattern datasets provided with the package include \code{\link[spatstat.data]{amacrine}}, \code{\link[spatstat.data]{betacells}}, \code{\link[spatstat.data]{bramblecanes}}, \code{\link[spatstat.data]{cells}}, \code{\link[spatstat.data]{demopat}}, \code{\link[spatstat.data]{ganglia}}, \code{\link[spatstat.data]{lansing}}, \code{\link[spatstat.data]{longleaf}}, \code{\link[spatstat.data]{nztrees}}, \code{\link[spatstat.data]{redwood}}, \code{\link[spatstat.data]{simdat}} and \code{\link[spatstat.data]{swedishpines}}. Point patterns may be scanned from your own data files by \code{\link{scanpp}} or by using \code{\link{read.table}} and \code{\link{as.ppp}}. They may be manipulated by the functions \code{\link{[.ppp}} and \code{\link{superimpose}}. Point pattern objects can be plotted just by typing \code{plot(X)} which invokes the \code{plot} method for point pattern objects, \code{\link{plot.ppp}}. See \code{\link{plot.ppp}} for further information. There are also methods for \code{summary} and \code{print} for point patterns. Use \code{summary(X)} to see a useful description of the data. Patterns may be generated at random by \code{\link[spatstat.random]{runifpoint}}, \code{\link[spatstat.random]{rpoispp}}, \code{\link[spatstat.random]{rMaternI}}, \code{\link[spatstat.random]{rMaternII}}, \code{\link[spatstat.random]{rSSI}}, \code{\link[spatstat.random]{rNeymanScott}}, \code{\link[spatstat.random]{rMatClust}}, and \code{\link[spatstat.random]{rThomas}}. Most functions which are intended to operate on a window (of class \code{\link{owin}}) will, if presented with a \code{\link{ppp}} object instead, automatically extract the window information from the point pattern. } \seealso{ \code{\link{owin}}, \code{\link{ppp}}, \code{\link{as.ppp}}, \code{\link{[.ppp}} } \section{Warnings}{ The internal representation of marks is likely to change in the next release of this package. } \examples{ x <- runif(100) y <- runif(100) X <- ppp(x, y, c(0,1),c(0,1)) X if(human <- interactive()) plot(X) mar <- sample(1:3, 100, replace=TRUE) mm <- ppp(x, y, c(0,1), c(0,1), marks=mar) if(human) plot(mm) # points with mark equal to 2 ss <- mm[ mm$marks == 2 , ] if(human) plot(ss) # left half of pattern 'mm' lu <- owin(c(0,0.5),c(0,1)) mmleft <- mm[ , lu] if(human) plot(mmleft) if(FALSE) { # input data from file qq <- scanpp("my.table", unit.square()) # interactively build a point pattern plot(unit.square()) X <- as.ppp(locator(10), unit.square()) plot(X) } } \author{\adrian and \rolf } \keyword{spatial} \keyword{attribute} spatstat.geom/man/as.layered.Rd0000644000176200001440000000356314611065345016150 0ustar liggesusers\name{as.layered} \alias{as.layered} \alias{as.layered.default} \alias{as.layered.ppp} \alias{as.layered.splitppp} \alias{as.layered.solist} \alias{as.layered.listof} \title{Convert Data To Layered Object} \description{ Converts spatial data into a layered object. } \usage{ as.layered(X) \method{as.layered}{default}(X) \method{as.layered}{ppp}(X) \method{as.layered}{splitppp}(X) \method{as.layered}{solist}(X) \method{as.layered}{listof}(X) } \arguments{ \item{X}{ Some kind of spatial data. } } \value{ An object of class \code{"layered"} (see \code{\link{layered}}). } \details{ This function converts the object \code{X} into an object of class \code{"layered"}. The argument \code{X} should contain some kind of spatial data such as a point pattern, window, or pixel image. If \code{X} is a simple object then it will be converted into a \code{layered} object containing only one layer which is equivalent to \code{X}. If \code{X} can be interpreted as consisting of multiple layers of data, then the result will be a \code{layered} object consisting of these separate layers of data. \itemize{ \item if \code{X} is a list of class \code{"listof"} or \code{"solist"}, then \code{as.layered(X)} consists of several layers, one for each entry in the list \code{X}; \item if \code{X} is a multitype point pattern, then \code{as.layered(X)} consists of several layers, each containing the sub-pattern consisting of points of one type; \item if \code{X} is a vector-valued measure, then \code{as.layered(X)} consists of several layers, each containing a scalar-valued measure. } } \seealso{ \code{\link[spatstat.model]{as.layered.msr}}, \code{\link{layered}}, \code{\link{split.ppp}} } \examples{ as.layered(cells) as.layered(amacrine) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.im.Rd0000644000176200001440000003415414643111575015132 0ustar liggesusers\name{as.im} \alias{as.im} \alias{as.im.im} \alias{as.im.owin} \alias{as.im.matrix} \alias{as.im.tess} \alias{as.im.function} \alias{as.im.funxy} \alias{as.im.expression} \alias{as.im.distfun} \alias{as.im.nnfun} \alias{as.im.data.frame} \alias{as.im.default} \title{Convert to Pixel Image} \description{ Converts various kinds of data to a pixel image } \usage{ as.im(X, \dots) \method{as.im}{im}(X, W=NULL, \dots, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL) \method{as.im}{owin}(X, W=NULL, \dots, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, value=1) \method{as.im}{matrix}(X, W=NULL, \dots) \method{as.im}{tess}(X, W=NULL, \dots, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, values=NULL) \method{as.im}{function}(X, W=NULL, \dots, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, stringsAsFactors=NULL, strict=FALSE, drop=TRUE) \method{as.im}{funxy}(X, W=Window(X), \dots) \method{as.im}{expression}(X, W=NULL, \dots) \method{as.im}{distfun}(X, W=NULL, \dots, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, approx=TRUE) \method{as.im}{nnfun}(X, W=NULL, \dots, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL, approx=TRUE) \method{as.im}{data.frame}(X, \dots, step, fatal=TRUE, drop=TRUE) \method{as.im}{default}(X, W=NULL, \dots, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame"), na.replace=NULL) } \arguments{ \item{X}{Data to be converted to a pixel image.} \item{W}{Window object which determines the spatial domain and pixel array geometry. } \item{\dots}{Additional arguments passed to \code{X} when \code{X} is a function.} \item{eps,dimyx,xy,rule.eps}{ Optional parameters passed to \code{\link[spatstat.geom]{as.mask}} which determine the pixel array geometry. See \code{\link[spatstat.geom]{as.mask}}. } \item{na.replace}{Optional value to replace \code{NA} entries in the output image. } \item{value}{Optional. The value to be assigned to pixels inside the window, if \code{X} is a window. A single atomic value (numeric, integer, logical etc). } \item{values}{Optional. Vector of values to be assigned to each tile of the tessellation, when \code{X} is a tessellation. An atomic vector (numeric, integer, logical etc.) } \item{strict}{ Logical value indicating whether to match formal arguments of \code{X} when \code{X} is a function. If \code{strict=FALSE} (the default), all the \code{\dots} arguments are passed to \code{X}. If \code{strict=TRUE}, only named arguments are passed, and only if they match the names of formal arguments of \code{X}. } \item{step}{ Optional. A single number, or numeric vector of length 2, giving the grid step lengths in the \eqn{x} and \eqn{y} directions. } \item{fatal}{ Logical value indicating what to do if the resulting image would be too large for available memory. If \code{fatal=TRUE} (the default), an error occurs. If \code{fatal=FALSE}, a warning is issued and \code{NULL} is returned. } \item{drop}{ Logical value indicating what to do if the result would normally be a list of pixel images but the list contains only one image. If \code{drop=TRUE} (the default), the pixel image is extracted and the result is a pixel image. If \code{drop=FALSE}, this list is returned as the result. } \item{stringsAsFactors}{ Logical value (passed to \code{\link[base]{data.frame}}) specifying how to handle pixel values which are character strings. If \code{TRUE}, character values are interpreted as factor levels. If \code{FALSE}, they remain as character strings. The default depends on the version of \R. See section \emph{Handling Character Strings}. } \item{approx}{ Logical value indicating whether to compute an approximate result at faster speed. } } \details{ This function converts the data \code{X} into a pixel image object of class \code{"im"} (see \code{\link{im.object}}). The function \code{as.im} is generic, with methods for the classes listed above. Currently \code{X} may be any of the following: \itemize{ \item a pixel image object, of class \code{"im"}. \item a window object, of class \code{"owin"} (see \code{\link{owin.object}}). The result is an image with all pixel entries equal to \code{value} inside the window \code{X}, and \code{NA} outside. \item a matrix. \item a tessellation (object of class \code{"tess"}). By default, the result is a factor-valued image, with one factor level corresponding to each tile of the tessellation. Pixels are classified according to the tile of the tessellation into which they fall. If argument \code{values} is given, the result is a pixel image in which every pixel inside the \code{i}-th tile of the tessellation has pixel value equal to \code{values[i]}. \item a single number (or a single logical, complex, factor or character value). The result is an image with all pixel entries equal to this constant value inside the window \code{W} (and \code{NA} outside, unless the argument \code{na.replace} is given). Argument \code{W} is required. \item a function of the form \code{function(x, y, ...)} which is to be evaluated to yield the image pixel values. In this case, the additional argument \code{W} must be present. This window will be converted to a binary image mask. Then the function \code{X} will be evaluated in the form \code{X(x, y, ...)} where \code{x} and \code{y} are \bold{vectors} containing the \eqn{x} and \eqn{y} coordinates of all the pixels in the image mask, and \code{...} are any extra arguments given. This function must return a vector or factor of the same length as the input vectors, giving the pixel values. \item an object of class \code{"funxy"} representing a \code{function(x,y,...)} defined in a spatial region. The function will be evaluated as described above. The window \code{W} defaults to the domain of definition of the function. \item an object of class \code{"funxy"} which also belongs to one of the following special classes. If \code{approx=TRUE} (the default), the function will be evaluated approximately using a very fast algorithm. If \code{approx=FALSE}, the function will be evaluated exactly at each grid location as described above. \itemize{ \item an object of class \code{"distfun"} representing a distance function (created by the command \code{\link{distfun}}). The fast approximation is the distance transform \code{\link{distmap}}. \item an object of class \code{"nnfun"} representing a nearest neighbour function (created by the command \code{\link{nnfun}}). The fast approximation is \code{\link{nnmap}}. \item an object of class \code{"densityfun"} representing a kernel estimate of intensity (created by the command \code{\link[spatstat.explore]{densityfun}}). The fast approximation is the Fast Fourier Transform algorithm in \code{\link[spatstat.explore]{density.ppp}}. \item an object of class \code{"Smoothfun"} representing kernel-smoothed values (created by the command \code{\link[spatstat.explore]{Smoothfun}}). The fast approximation is the Fast Fourier Transform algorithm in \code{\link[spatstat.explore]{Smooth.ppp}}. } \item An \code{expression} involving the variables \code{x} and \code{y} representing the spatial coordinates, and possibly also involving other variables. The additional argument \code{W} must be present; it will be converted to a binary image mask. The expression \code{X} will be evaluated in an environment where \code{x} and \code{y} are \bold{vectors} containing the spatial coordinates of all the pixels in the image mask. Evaluation of the expression \code{X} must yield a vector or factor, of the same length as \code{x} and \code{y}, giving the pixel values. \item a list with entries \code{x, y, z} in the format expected by the standard \code{R} functions \code{\link{image.default}} and \code{\link{contour.default}}. That is, \code{z} is a matrix of pixel values, \code{x} and \code{y} are vectors of \eqn{x} and \eqn{y} coordinates respectively, and \code{z[i,j]} is the pixel value for the location \code{(x[i],y[j])}. \item a point pattern (object of class \code{"ppp"}). See the separate documentation for \code{\link{as.im.ppp}}. \item A data frame with at least three columns. Columns named \code{x}, \code{y} and \code{z}, if present, will be assumed to contain the spatial coordinates and the pixel values, respectively. Otherwise the \code{x} and \code{y} coordinates will be taken from the first two columns of the data frame, and any remaining columns will be interpreted as pixel values. } The spatial domain (enclosing rectangle) of the pixel image is determined by the argument \code{W}. If \code{W} is absent, the spatial domain is determined by \code{X}. When \code{X} is a function, a matrix, or a single numerical value, \code{W} is required. The pixel array dimensions of the final resulting image are determined by (in priority order) \itemize{ \item the argument \code{eps}, \code{dimyx} or \code{xy} if present; \item the pixel dimensions of the window \code{W}, if it is present and if it is a binary mask; \item the pixel dimensions of \code{X} if it is an image, a binary mask, or a \code{list(x,y,z)}; \item the default pixel dimensions, controlled by \code{\link{spatstat.options}}. } Note that if \code{eps}, \code{dimyx} or \code{xy} is given, this will override the pixel dimensions of \code{X} if it has them. Thus, \code{as.im} can be used to change an image's pixel dimensions. If the argument \code{na.replace} is given, then all \code{NA} entries in the image will be replaced by this value. The resulting image is then defined everwhere on the full rectangular domain, instead of a smaller window. Here \code{na.replace} should be a single value, of the same type as the other entries in the image. If \code{X} is a pixel image that was created by an older version of \pkg{spatstat}, the command \code{X <- as.im(X)} will repair the internal format of \code{X} so that it conforms to the current version of \pkg{spatstat}. If \code{X} is a data frame with \code{m} columns, then \code{m-2} columns of data are interpreted as pixel values, yielding \code{m-2} pixel images. The result of \code{as.im.data.frame} is a list of pixel images, belonging to the class \code{"imlist"}. If \code{m = 3} and \code{drop=TRUE} (the default), then the result is a pixel image rather than a list containing this image. If \code{X} is a \code{function(x,y)} which returns a matrix of values, then \code{as.im(X, W)} will be a list of pixel images. } \section{Character-valued images}{ By default, if the pixel value data are character strings, they will be treated as levels of a factor, and the resulting image will be factor-valued. To prevent the conversion of character strings to factors, use the argument \code{stringsAsFactors=FALSE}, which is recognised by most of the methods for \code{as.im}, or alternatively set \code{options(stringsAsFactors=FALSE)}. } \section{Handling Character Strings}{ The argument \code{stringsAsFactors} is a logical value (passed to \code{\link[base]{data.frame}}) specifying how to handle pixel values which are character strings. If \code{TRUE}, character values are interpreted as factor levels. If \code{FALSE}, they remain as character strings. The default values of \code{stringsAsFactors} depends on the version of \R. \itemize{ \item In \R versions \code{< 4.1.0} the factory-fresh default is \code{stringsAsFactors=FALSE} and the default can be changed by setting \code{options(stringsAsFactors=FALSE)}. \item In \R versions \code{>= 4.1.0} the default is \code{stringsAsFactors=FALSE} and there is no option to change the default. } } \value{ A pixel image (object of class \code{"im"}), or a list of pixel images, or \code{NULL} if the conversion failed. } \seealso{ Separate documentation for \code{\link{as.im.ppp}} } \examples{ # window object W <- Window(demopat) plot(W) Z <- as.im(W) image(Z) # function Z <- as.im(function(x,y) {x^2 + y^2}, unit.square()) image(Z) # or as an expression Z <- as.im(expression(x^2+y^2), square(1)) # function with extra arguments f <- function(x, y, x0, y0) { sqrt((x - x0)^2 + (y-y0)^2) } Z <- as.im(f, unit.square(), x0=0.5, y0=0.5) image(Z) # Revisit the Sixties Z <- as.im(f, letterR, x0=2.5, y0=2) image(Z) # usual convention in R stuff <- list(x=1:10, y=1:10, z=matrix(1:100, nrow=10)) Z <- as.im(stuff) # convert to finer grid Z <- as.im(Z, dimyx=256) #' distance functions d <- distfun(redwood) Zapprox <- as.im(d) Zexact <- as.im(d, approx=FALSE) plot(solist(approx=Zapprox, exact=Zexact), main="") # pixellate the Dirichlet tessellation Di <- dirichlet(redwood) plot(as.im(Di)) plot(Di, add=TRUE, border="white") # as.im.data.frame is the reverse of as.data.frame.im grad <- bei.extra$grad slopedata <- as.data.frame(grad) slope <- as.im(slopedata) unitname(grad) <- unitname(slope) <- unitname(grad) # for compatibility all.equal(slope, grad) # TRUE ## handling of character values as.im("a", W=letterR, na.replace="b") as.im("a", W=letterR, na.replace="b", stringsAsFactors=FALSE) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/harmonise.Rd0000644000176200001440000000263314611065346016104 0ustar liggesusers\name{harmonise} \alias{harmonise} \alias{harmonize} \title{Make Objects Compatible} \description{ Converts several objects of the same class to a common format so that they can be combined or compared. } \usage{ harmonise(\dots) harmonize(\dots) } \arguments{ \item{\dots}{ Any number of objects of the same class. } } \details{ This generic command takes any number of objects of the same class, and \emph{attempts} to make them compatible in the sense of \code{\link{compatible}} so that they can be combined or compared. There are methods for the classes \code{"fv"} (\code{\link[spatstat.explore]{harmonise.fv}}) and \code{"im"} (\code{\link{harmonise.im}}). All arguments \code{\dots} must be objects of the same class. The result will be a list, of length equal to the number of arguments \code{\dots}, containing new versions of each of these objects, converted to a common format. If the arguments were named (\code{name=value}) then the return value also carries these names. } \value{ A list, of length equal to the number of arguments \code{\dots}, whose entries are objects of the same class. If the arguments were named (\code{name=value}) then the return value also carries these names. } \author{ \spatstatAuthors. } \seealso{ \code{\link{compatible}}, \code{\link[spatstat.explore]{harmonise.fv}}, \code{\link{harmonise.im}} } \keyword{spatial} \keyword{manip} spatstat.geom/man/plot.pp3.Rd0000644000176200001440000000523214611065347015575 0ustar liggesusers\name{plot.pp3} \Rdversion{1.1} \alias{plot.pp3} \title{ Plot a Three-Dimensional Point Pattern } \description{ Plots a three-dimensional point pattern. } \usage{ \method{plot}{pp3}(x, ..., eye=NULL, org=NULL, theta=25, phi=15, type=c("p", "n", "h"), box.back=list(col="pink"), box.front=list(col="blue", lwd=2)) } \arguments{ \item{x}{ Three-dimensional point pattern (object of class \code{"pp3"}). } \item{\dots}{ Arguments passed to \code{\link[graphics]{points}} controlling the appearance of the points. } \item{eye}{ Optional. Eye position. A numeric vector of length 3 giving the location from which the scene is viewed. } \item{org}{ Optional. Origin (centre) of the view. A numeric vector of length 3 which will be at the centre of the view. } \item{theta,phi}{ Optional angular coordinates (in degrees) specifying the direction from which the scene is viewed: \code{theta} is the azimuth and \code{phi} is the colatitude. Ignored if \code{eye} is given. } \item{type}{ Type of plot: \code{type="p"} for points, \code{type="h"} for points on vertical lines, \code{type="n"} for box only. } \item{box.front,box.back}{ How to plot the three-dimensional box that contains the points. A list of graphical arguments passed to \code{\link[graphics]{segments}}, or a logical value indicating whether or not to plot the relevant part of the box. See Details. } } \details{ This is the plot method for objects of class \code{"pp3"}. It generates a two-dimensional plot of the point pattern \code{x} and its containing box as if they had been viewed from the location specified by \code{eye} (or from the direction specified by \code{theta} and \code{phi}). The edges of the box at the \sQuote{back} of the scene (as viewed from the eye position) are plotted first. Then the points are added. Finally the remaining \sQuote{front} edges are plotted. The arguments \code{box.back} and \code{box.front} specify graphical parameters for drawing the back and front edges, respectively. Alternatively \code{box.back=FALSE} specifies that the back edges shall not be drawn. Note that default values of arguments to \code{plot.pp3} can be set by \code{\link{spatstat.options}("par.pp3")}. } \value{Null.} \author{ \spatstatAuthors. } \seealso{ \code{\link{pp3}}, \code{\link{spatstat.options}}. } \examples{ X <- osteo$pts[[1]] plot(X, main="Osteocyte lacunae, animal 1, brick 1", cex=1.5, pch=16) plot(X, type="h", main="", box.back=list(lty=3)) } \keyword{spatial} \keyword{hplot} \concept{Three-dimensional} spatstat.geom/man/connected.ppp.Rd0000644000176200001440000000401514611065345016652 0ustar liggesusers\name{connected.ppp} \Rdversion{1.1} \alias{connected.ppp} \alias{connected.pp3} \title{ Connected Components of a Point Pattern } \description{ Finds the topologically-connected components of a point pattern, when all pairs of points closer than a threshold distance are joined. } \usage{ \method{connected}{ppp}(X, R, \dots) \method{connected}{pp3}(X, R, \dots) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"} or \code{"pp3"}). } \item{R}{ Threshold distance. Pairs of points closer than \code{R} units apart will be joined together. } \item{\dots}{ Other arguments, not recognised by these methods. } } \details{ This function can be used to identify clumps of points in a point pattern. The function \code{connected} is generic. This file documents the methods for point patterns in dimension two or three (objects of class \code{"ppp"} or \code{"pp3"}). The point pattern \code{X} is first converted into an abstract graph by joining every pair of points that lie closer than \code{R} units apart. Then the connected components of this graph are identified. Two points in \code{X} belong to the same connected component if they can be reached by a series of steps between points of \code{X}, each step being shorter than \code{R} units in length. The result is a vector of labels for the points of \code{X} where all the points in a connected component have the same label. } \value{ A point pattern, equivalent to \code{X} except that the points have factor-valued marks, with levels corresponding to the connected components. } \seealso{ \code{\link{connected.im}}, \code{\link{im.object}}, \code{\link{tess}} } \examples{ Y <- connected(redwoodfull, 0.1) if(interactive()) { plot(Y, cols=1:length(levels(marks(Y))), main="connected(redwoodfull, 0.1)") } X <- osteo$pts[[1]] Z <- connected(X, 32) if(interactive()) { plot(Z, col=marks(Z), main="") } } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/uniquemap.ppp.Rd0000644000176200001440000000300314636754420016716 0ustar liggesusers\name{uniquemap.ppp} \alias{uniquemap.ppp} \alias{uniquemap.lpp} \alias{uniquemap.ppx} \title{ Map Duplicate Entries to Unique Entries } \description{ Determine whether points in a point pattern are duplicated, choose a unique representative for each set of duplicates, and map the duplicates to the unique representative. } \usage{ \method{uniquemap}{ppp}(x) \method{uniquemap}{lpp}(x) \method{uniquemap}{ppx}(x) } \arguments{ \item{x}{ A point pattern (object of class \code{"ppp"}, \code{"lpp"}, \code{"pp3"} or \code{"ppx"}). } } \details{ The function \code{\link[spatstat.univar]{uniquemap}} is generic, with methods for point patterns, and a default method. This function determines whether any points of \code{x} are duplicated, and constructs a mapping of the indices of \code{x} so that all duplicates are mapped to a unique representative index. The result is an integer vector \code{u} such that \code{u[j] = i} if the points \code{x[i]} and \code{x[j]} are identical and point \code{i} has been chosen as the unique representative. The entry \code{u[i] = i} means either that point \code{i} is unique, or that it has been chosen as the unique representative of its equivalence class. } \value{ An integer vector. } \author{ \spatstatAuthors. } \seealso{ \code{\link{unique.ppp}}, \code{\link{duplicated.ppp}}, \code{\link[spatstat.univar]{uniquemap.default}} } \examples{ Y <- runifrect(4) X <- Y[c(1,2,3,4,2,1)] uniquemap(X) } \keyword{spatial} \keyword{methods} spatstat.geom/man/rev.colourmap.Rd0000644000176200001440000000152414723211063016702 0ustar liggesusers\name{rev.colourmap} \alias{rev.colourmap} \title{ Reverse the Colours in a Colour Map } \description{ Reverse the sequence of colour values in a colour map. } \usage{ \method{rev}{colourmap}(x) } \arguments{ \item{x}{ A colour map (object of class \code{"colourmap"}). } } \details{ This is a method for the generic \code{\link[base]{rev}} for the class of colour maps. The sequence of colour values in the colour map will be reversed, without changing any other details. } \value{ A colour map (object of class \code{"colourmap"}). } \author{ \spatstatAuthors. } \seealso{ \code{\link{colourmap}}, \code{\link{colouroutputs}} } \examples{ co <- colourmap(rainbow(100), range=c(-1,1)) opa <- par(mfrow=c(1,2)) plot(co, vertical=TRUE) plot(rev(co), vertical=TRUE) par(opa) } \keyword{spatial} \keyword{color} spatstat.geom/man/setcov.Rd0000644000176200001440000000363214643111575015423 0ustar liggesusers\name{setcov} \alias{setcov} \title{Set Covariance of a Window} \description{ Computes the set covariance function of a window. } \usage{ setcov(W, V=W, \dots) } \arguments{ \item{W}{ A window (object of class \code{"owin"}. } \item{V}{ Optional. Another window. } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} to control the pixel resolution. } } \value{ A pixel image (an object of class \code{"im"}) representing the set covariance function of \code{W}, or the cross-covariance of \code{W} and \code{V}. } \details{ The set covariance function of a region \eqn{W} in the plane is the function \eqn{C(v)} defined for each vector \eqn{v} as the area of the intersection between \eqn{W} and \eqn{W+v}, where \eqn{W+v} is the set obtained by shifting (translating) \eqn{W} by \eqn{v}. We may interpret \eqn{C(v)} as the area of the set of all points \eqn{x} in \eqn{W} such that \eqn{x+v} also lies in \eqn{W}. This command computes a discretised approximation to the set covariance function of any plane region \eqn{W} represented as a window object (of class \code{"owin"}, see \code{\link{owin.object}}). The return value is a pixel image (object of class \code{"im"}) whose greyscale values are values of the set covariance function. The set covariance is computed using the Fast Fourier Transform, unless \code{W} is a rectangle, when an exact formula is used. If the argument \code{V} is present, then \code{setcov(W,V)} computes the set \emph{cross-covariance} function \eqn{C(x)} defined for each vector \eqn{x} as the area of the intersection between \eqn{W} and \eqn{V+x}. } \seealso{ \code{\link{imcov}}, \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{erosion}} } \examples{ w <- owin(c(0,1),c(0,1)) v <- setcov(w) plot(v) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/nndist.pp3.Rd0000644000176200001440000001030614742317357016122 0ustar liggesusers\name{nndist.pp3} \alias{nndist.pp3} \title{Nearest neighbour distances in three dimensions} \description{ Computes the distance from each point to its nearest neighbour in a three-dimensional point pattern. Alternatively computes the distance to the second nearest neighbour, or third nearest, etc. } \usage{ \method{nndist}{pp3}(X, \dots, k=1, by=NULL) } \arguments{ \item{X}{ Three-dimensional point pattern (object of class \code{"pp3"}). } \item{\dots}{ Ignored. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } \item{by}{ Optional. A factor, which separates \code{X} into groups. The algorithm will compute the distance to the nearest point in each group. } } \value{ Numeric vector or matrix containing the nearest neighbour distances for each point. If \code{k = 1} (the default), the return value is a numeric vector \code{v} such that \code{v[i]} is the nearest neighbour distance for the \code{i}th data point. If \code{k} is a single integer, then the return value is a numeric vector \code{v} such that \code{v[i]} is the \code{k}th nearest neighbour distance for the \code{i}th data point. If \code{k} is a vector, then the return value is a matrix \code{m} such that \code{m[i,j]} is the \code{k[j]}th nearest neighbour distance for the \code{i}th data point. } \details{ This function computes the Euclidean distance from each point in a three-dimensional point pattern to its nearest neighbour (the nearest other point of the pattern). If \code{k} is specified, it computes the distance to the \code{k}th nearest neighbour. The function \code{nndist} is generic; this function \code{nndist.pp3} is the method for the class \code{"pp3"}. The argument \code{k} may be a single integer, or an integer vector. If it is a vector, then the \eqn{k}th nearest neighbour distances are computed for each value of \eqn{k} specified in the vector. If there is only one point (if \code{x} has length 1), then a nearest neighbour distance of \code{Inf} is returned. If there are no points (if \code{x} has length zero) a numeric vector of length zero is returned. If the argument \code{by} is given, it should be a \code{factor}, of length equal to the number of points in \code{X}. This factor effectively partitions \code{X} into subsets, each subset associated with one of the levels of \code{X}. The algorithm will then compute, for each point of \code{X}, the distance to the nearest neighbour \emph{in each subset}. To identify \emph{which} point is the nearest neighbour of a given point, use \code{\link{nnwhich}}. To use the nearest neighbour distances for statistical inference, it is often advisable to use the edge-corrected empirical distribution, computed by \code{\link[spatstat.explore]{G3est}}. To find the nearest neighbour distances from one point pattern to another point pattern, use \code{\link{nncross}}. } \section{Distance values}{ The values returned by \code{nndist(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{nndist(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \section{Warnings}{ An infinite or \code{NA} value is returned if the distance is not defined (e.g. if there is only one point in the point pattern). } \seealso{ \code{\link{nndist}}, \code{\link{pairdist}}, \code{\link[spatstat.explore]{G3est}}, \code{\link{nnwhich}} } \examples{ X <- pp3(runif(40), runif(40), runif(40), box3(c(0,1))) # nearest neighbours d <- nndist(X) # second nearest neighbours d2 <- nndist(X, k=2) # first, second and third nearest d1to3 <- nndist(X, k=1:3) # distance to nearest point in each group marks(X) <- factor(rep(letters[1:4], 10)) dby <- nndist(X, by=marks(X)) } \author{ \adrian based on code for two dimensions by \pavel. } \keyword{spatial} \keyword{math} \concept{Three-dimensional} spatstat.geom/man/hist.funxy.Rd0000644000176200001440000000377314611065346016244 0ustar liggesusers\name{hist.funxy} \alias{hist.funxy} \title{Histogram of Values of a Spatial Function} \description{ Computes and displays a histogram of the values of a spatial function of class \code{"funxy"}. } \usage{ \method{hist}{funxy}(x, \dots, xname) } \arguments{ \item{x}{A pixel image (object of class \code{"funxy"}).} \item{\dots}{ Arguments passed to \code{\link{as.im}} or \code{\link{hist.im}}. } \item{xname}{ Optional. Character string to be used as the name of the dataset \code{x}. } } \details{ This function computes and (by default) displays a histogram of the values of the function \code{x}. An object of class \code{"funxy"} describes a function of spatial location. It is a \code{function(x,y,..)} in the \R language, with additional attributes. The function \code{hist.funxy} is a method for the generic function \code{\link{hist}} for the class \code{"funxy"}. The function is first converted to a pixel image using \code{\link{as.im}}, then \code{\link{hist.im}} is called to produce the histogram. Any arguments in \code{...} are passed to \code{\link{as.im}} to determine the pixel resolution, or to \code{\link{hist.im}} to determine the histogram breaks and to control or suppress plotting. Useful arguments include \code{W} for the spatial domain, \code{eps,dimyx} for pixel resolution, \code{main} for the main title. } \value{ An object of class \code{"histogram"} as returned by \code{\link[graphics:hist]{hist.default}}. This object can be plotted. } \seealso{ \code{\link[spatstat.explore]{spatialcdf}} for the cumulative distribution function of an image or function. \code{\link{hist}}, \code{\link{hist.default}}. For other statistical graphics such as Q-Q plots, use \code{as.im(X)[]} to extract the pixel values of image \code{X}, and apply the usual statistical graphics commands. } \examples{ f <- funxy(function(x,y) {x^2}, unit.square()) hist(f) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} spatstat.geom/man/interp.colourmap.Rd0000644000176200001440000000261514611065346017420 0ustar liggesusers\name{interp.colourmap} \alias{interp.colourmap} \title{ Interpolate smoothly between specified colours } \description{ Given a colourmap object which maps numbers to colours, this function interpolates smoothly between the colours, yielding a new colour map. } \usage{ interp.colourmap(m, n = 512) } \arguments{ \item{m}{ A colour map (object of class \code{"colourmap"}). } \item{n}{ Number of colour steps to be created in the new colour map. } } \details{ Given a colourmap object \code{m}, which maps numerical values to colours, this function interpolates the mapping, yielding a new colour map. This makes it easy to build a colour map that has smooth gradation between different colours or shades. First specify a small vector of numbers \code{x} which should be mapped to specific colours \code{y}. Use \code{m <- colourmap(y, inputs=x)} to create a colourmap that represents this simple mapping. Then apply \code{interp.colourmap(m)} to obtain a smooth transition between these points. } \value{ Another colour map (object of class \code{"colourmap"}). } \seealso{ \code{\link{colourmap}}, \code{\link{tweak.colourmap}}, \code{\link[spatstat.geom:colourtools]{colourtools}}. } \examples{ co <- colourmap(inputs=c(0, 0.5, 1), c("black", "red", "white")) plot(interp.colourmap(co)) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{color} spatstat.geom/man/plot.pppmatching.Rd0000644000176200001440000000430714611065347017407 0ustar liggesusers\name{plot.pppmatching} \alias{plot.pppmatching} \title{ Plot a Point Matching } \description{ Plot an object of class \code{"pppmatching"} which represents a matching of two planar point patterns. } \usage{ \method{plot}{pppmatching}(x, addmatch = NULL, main = NULL, \dots, adjust = 1) } \arguments{ \item{x}{ Point pattern matching object (class \code{"pppmatching"}) to be plotted. } \item{addmatch}{ Optional. A matrix indicating additional pairs of points that should be matched. See Details. } \item{main}{ Main title for the plot. } \item{\dots}{ Additional arguments passed to other plot methods. } \item{adjust}{ Adjustment factor for the widths of line segments. A positive number. } } \details{ The object \code{x} represents a matching found between two point patterns \code{X} and \code{Y}. The matching may be incomplete. See \code{\link{pppmatching.object}} for further description. This function plots the matching by drawing the two point patterns \code{X} and \code{Y} as red and blue dots respectively, and drawing line segments between each pair of matched points. The width of the line segments is proportional to the strength of matching. The proportionality constant can be adjusted using the argument \code{adjust}. Additional graphics arguments \code{\dots} control the plotting of the window (and are passed to \code{\link{plot.owin}}) and the plotting of the line segments (and are passed to \code{\link{plot.psp}}, and ultimately to the base graphics function \code{\link[graphics]{polygon}}). The argument \code{addmatch} is for use mainly by developers to study algorithms which update the matching. If \code{addmatch} is given, it should be a matrix with dimensions \code{npoints(X) * npoints(Y)}. If \code{addmatch[i,j] > 0} then a light grey line segment will be drawn between \code{X[i]} and \code{Y[j}. } \value{ Null. } \author{ Dominic Schuhmacher and \adrian. } \seealso{ \code{\link{pppmatching.object}} } \examples{ X <- runifrect(7) Y <- runifrect(7) am <- r2dtable(1, rep(10,7), rep(10,7))[[1]]/10 m2 <- pppmatching(X, Y, am) plot(m2, adjust=0.3) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/rexplode.Rd0000644000176200001440000000607014611065350015733 0ustar liggesusers\name{rexplode} \alias{rexplode} \alias{rexplode.ppp} \title{ Explode a Point Pattern by Displacing Duplicated Points } \description{ Given a point pattern which contains duplicated points, separate the duplicated points from each other by slightly perturbing their positions. } \usage{ rexplode(X, \dots) \method{rexplode}{ppp}(X, radius, \dots, nsim = 1, drop = TRUE) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"}). } \item{radius}{ Scale of perturbations. A positive numerical value. The displacement vectors will be uniformly distributed in a circle of this radius. There is a sensible default. Alternatively, \code{radius} may be a numeric vector of length equal to the number of points in \code{X}, giving a different displacement radius for each data point. Radii will be restricted to be less than or equal to the distance to the boundary of the window. } \item{\dots}{ Ignored. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \value{ A point pattern (an object of class \code{"ppp"}) or a list of point patterns. } \details{ Duplicated points in the point pattern \code{X} are identified. Each group of duplicated points is then \sQuote{exploded} by randomly displacing the point locations to form a circular arrangement around the original position. This function is an alternative to \code{\link{rjitter.ppp}}. Whereas \code{\link{rjitter.ppp}} applies independent random displacements to each data point, \code{rexplode.ppp} applies displacements only to the points that are duplicated, and the displacements are mutually dependent within each group of duplicates, to ensure that the displaced points are visually separated from each other. First the code ensures that the displacement radius for each data point is less than or equal to the distance to the boundary of the window. Then each group of duplicated points (or data points with the same location but possibly different mark values) is taken in turn. The first element of the group is randomly displaced by a vector uniformly distributed in a circle of radius \code{radius}. The remaining elements of the group are then positioned around the original location, at the same distance from the orginal location, with equal angular spacing from the first point. The result is that each group of duplicated points becomes a circular pattern centred around the original location. } \author{ \adrian. } \seealso{ \code{\link{rjitter.ppp}} } \examples{ ## create a pattern containing duplicated points X <- runifrect(5) \%mark\% letters[1:5] X <- X[rep(1:5, 1 + rpois(5, 2))] ## explode it Y <- rexplode(X, 0.05) ## display if(interactive()) { plot(solist(X=X, 'explode(X)'=Y), main="", cols=2:6, cex=1.25, leg.side="bottom") } } \keyword{spatial} \keyword{manip} \keyword{datagen} spatstat.geom/man/Window.Rd0000644000176200001440000000601014611065344015355 0ustar liggesusers\name{Window} \alias{Window} \alias{Window<-} \alias{Window.ppp} \alias{Window<-.ppp} \alias{Window.quad} \alias{Window<-.quad} \alias{Window.psp} \alias{Window<-.psp} \alias{Window.im} \alias{Window<-.im} \title{ Extract or Change the Window of a Spatial Object } \description{ Given a spatial object (such as a point pattern or pixel image) in two dimensions, these functions extract or change the window in which the object is defined. } \usage{ Window(X, \dots) Window(X, \dots) <- value \method{Window}{ppp}(X, \dots) \method{Window}{ppp}(X, \dots) <- value \method{Window}{quad}(X, \dots) \method{Window}{quad}(X, \dots) <- value \method{Window}{psp}(X, \dots) \method{Window}{psp}(X, \dots) <- value \method{Window}{im}(X, \dots) \method{Window}{im}(X, \dots) <- value } \arguments{ \item{X}{ A spatial object such as a point pattern, line segment pattern or pixel image. } \item{\dots}{ Extra arguments. They are ignored by all the methods listed here. } \item{value}{ Another window (object of class \code{"owin"}) to be used as the window for \code{X}. } } \details{ The functions \code{Window} and \code{Window<-} are generic. \code{Window(X)} extracts the spatial window in which \code{X} is defined. \code{Window(X) <- W} changes the window in which \code{X} is defined to the new window \code{W}, and \emph{discards any data outside} \code{W}. In particular: \itemize{ \item If \code{X} is a point pattern (object of class \code{"ppp"}) then \code{Window(X) <- W} discards any points of \code{X} which fall outside \code{W}. \item If \code{X} is a quadrature scheme (object of class \code{"quad"}) then \code{Window(X) <- W} discards any points of \code{X} which fall outside \code{W}, and discards the corresponding quadrature weights. \item If \code{X} is a line segment pattern (object of class \code{"psp"}) then \code{Window(X) <- W} clips the segments of \code{X} to the boundaries of \code{W}. \item If \code{X} is a pixel image (object of class \code{"im"}) then \code{Window(X) <- W} has the effect that pixels lying outside \code{W} are retained but their pixel values are set to \code{NA}. } Many other classes of spatial object have a method for \code{Window}, but not \code{Window<-}. See \code{\link[spatstat.geom]{Window.tess}}. } \value{ The result of \code{Window} is a window (object of class \code{"owin"}). The result of \code{Window<-} is the updated object \code{X}, of the same class as \code{X}. } \author{ \spatstatAuthors. } \seealso{ \code{\link[spatstat.model]{Window.ppm}} } \examples{ ## point patterns Window(cells) X <- demopat Window(X) Window(X) <- as.rectangle(Window(X)) ## line segment patterns X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) Window(X) Window(X) <- square(0.5) ## images Z <- setcov(owin()) Window(Z) Window(Z) <- square(0.5) } \keyword{spatial} \keyword{manip} spatstat.geom/man/default.symbolmap.Rd0000644000176200001440000000221414611065345017537 0ustar liggesusers\name{default.symbolmap} \alias{default.symbolmap} \title{ Default Symbol Map for Plotting a Spatial Pattern } \description{ Determines the symbol map for plotting a spatial pattern, when one is not supplied by the user. } \usage{ default.symbolmap(x, \dots) } \arguments{ \item{x}{ A spatial object in the \pkg{spatstat} package, such as a point pattern (class \code{"ppp"}). } \item{\dots}{ Additional arguments passed to methods. } } \details{ In the \pkg{spatstat} package, an object of class \code{"symbolmap"} defines a mapping between data and graphical symbols. If a plot command \code{plot(x, \dots)} has been issued, and if the arguments were not sufficient to determine the symbol map that should be used, then \code{default.symbolmap(x, \dots)} will be executed to determine the default symbol map. The function \code{default.symbolmap} is generic, with a method for point patterns (class \code{"ppp"}) and possibly for other classes. } \value{ A symbol map (object of class \code{"symbolmap"}). } \author{ \adrian } \seealso{ \code{\link{default.symbolmap.ppp}} } \keyword{spatial} \keyword{hplot} spatstat.geom/man/split.ppx.Rd0000644000176200001440000000752414611065350016057 0ustar liggesusers\name{split.ppx} \alias{split.ppx} \title{Divide Multidimensional Point Pattern into Sub-patterns} \description{ Divides a multidimensional point pattern into several sub-patterns, according to their marks, or according to any user-specified grouping. } \usage{ \method{split}{ppx}(x, f = marks(x), drop=FALSE, un=NULL, \dots) } \arguments{ \item{x}{ A multi-dimensional point pattern. An object of class \code{"ppx"}. } \item{f}{ Data determining the grouping. Either a factor, a logical vector, or the name of one of the columns of marks. } \item{drop}{ Logical. Determines whether empty groups will be deleted. } \item{un}{ Logical. Determines whether the resulting subpatterns will be unmarked (i.e. whether marks will be removed from the points in each subpattern). } \item{\dots}{ Other arguments are ignored. } } \value{ A list of point patterns. The components of the list are named by the levels of \code{f}. The list also has the class \code{"splitppx"} and \code{"anylist"}. } \details{ The generic command \code{\link[base]{split}} allows a dataset to be separated into subsets according to the value of a grouping variable. The function \code{split.ppx} is a method for the generic \code{\link[base]{split}} for the class \code{"ppx"} of multidimensional point patterns. It divides up the points of the point pattern \code{x} into several sub-patterns according to the values of \code{f}. The result is a list of point patterns. The argument \code{f} may be \itemize{ \item a factor, of length equal to the number of points in \code{x}. The levels of \code{f} determine the destination of each point in \code{x}. The \code{i}th point of \code{x} will be placed in the sub-pattern \code{split.ppx(x)$l} where \code{l = f[i]}. \item the character string \code{"marks"}, if \code{marks(x)} is a factor. \item a character string, matching the name of one of the columns of marks, if \code{marks(x)} is a data frame or hyperframe. This column should be a factor. } If \code{f} is missing, then it will be determined by the marks of the point pattern. The pattern \code{x} can be either \itemize{ \item a multitype point pattern (a marked point pattern whose marks vector is a factor). Then \code{f} is taken to be the marks vector. The effect is that the points of each type are separated into different point patterns. \item a marked point pattern with a data frame or hyperframe of marks, containing at least one column that is a factor. The first such column will be used to determine the splitting factor \code{f}. } Some of the sub-patterns created by the split may be empty. If \code{drop=TRUE}, then empty sub-patterns will be deleted from the list. If \code{drop=FALSE} then they are retained. The argument \code{un} determines how to handle marks in the case where \code{x} is a marked point pattern. If \code{un=TRUE} then the marks of the points will be discarded when they are split into groups, while if \code{un=FALSE} then the marks will be retained. If \code{f} and \code{un} are both missing, then the default is \code{un=TRUE} for multitype point patterns and \code{un=FALSE} for marked point patterns with a data frame of marks. The result of \code{split.ppx} has class \code{"splitppx"} and \code{"anylist"}. There are methods for \code{print}, \code{summary} and \code{plot}. } \seealso{ \code{\link{ppx}}, \code{\link{plot.anylist}} } \examples{ df <- data.frame(x=runif(4),y=runif(4),t=runif(4), age=factor(rep(c("old", "new"), 2)), size=runif(4)) X <- ppx(data=df, coord.type=c("s","s","t","m","m")) X split(X) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} \keyword{manip} spatstat.geom/man/quadrats.Rd0000644000176200001440000000621714611065350015740 0ustar liggesusers\name{quadrats} \alias{quadrats} \title{Divide Region into Quadrats} \description{ Divides window into rectangular quadrats and returns the quadrats as a tessellation. } \usage{ quadrats(X, nx = 5, ny = nx, xbreaks = NULL, ybreaks = NULL, keepempty=FALSE) } \arguments{ \item{X}{ A window (object of class \code{"owin"}) or anything that can be coerced to a window using \code{\link{as.owin}}, such as a point pattern. } \item{nx,ny}{ Numbers of quadrats in the \eqn{x} and \eqn{y} directions. Incompatible with \code{xbreaks} and \code{ybreaks}. } \item{xbreaks}{ Numeric vector giving the \eqn{x} coordinates of the boundaries of the quadrats. Incompatible with \code{nx}. } \item{ybreaks}{ Numeric vector giving the \eqn{y} coordinates of the boundaries of the quadrats. Incompatible with \code{ny}. } \item{keepempty}{ Logical value indicating whether to delete or retain empty quadrats. See Details. } } \details{ If the window \code{X} is a rectangle, it is divided into an \code{nx * ny} grid of rectangular tiles or `quadrats'. If \code{X} is not a rectangle, then the bounding rectangle of \code{X} is first divided into an \code{nx * ny} grid of rectangular tiles, and these tiles are then intersected with the window \code{X}. The resulting tiles are returned as a tessellation (object of class \code{"tess"}) which can be plotted and used in other analyses. If \code{xbreaks} is given, it should be a numeric vector giving the \eqn{x} coordinates of the quadrat boundaries. If it is not given, it defaults to a sequence of \code{nx+1} values equally spaced over the range of \eqn{x} coordinates in the window \code{Window(X)}. Similarly if \code{ybreaks} is given, it should be a numeric vector giving the \eqn{y} coordinates of the quadrat boundaries. It defaults to a vector of \code{ny+1} values equally spaced over the range of \eqn{y} coordinates in the window. The lengths of \code{xbreaks} and \code{ybreaks} may be different. By default (if \code{keepempty=FALSE}), any rectangular tile which does not intersect the window \code{X} is ignored, and only the non-empty intersections are treated as quadrats, so the tessellation may consist of fewer than \code{nx * ny} tiles. If \code{keepempty=TRUE}, empty intersections are retained, and the tessellation always contains exactly \code{nx * ny} tiles, some of which may be empty. } \value{ A tessellation (object of class \code{"tess"}) as described under \code{\link{tess}}. } \examples{ W <- square(10) Z <- quadrats(W, 4, 5) plot(Z) plot(quadrats(letterR, 5, 7)) } \seealso{ For calculations using quadrats, see \code{\link{quadratcount}}, \code{\link[spatstat.explore]{quadrat.test}}, \code{\link[spatstat.random]{quadratresample}} For other kinds of tessellations, see \code{\link{tess}}, \code{\link{hextess}}, \code{\link{venn.tess}}, \code{\link{polartess}}, \code{\link{dirichlet}}, \code{\link{delaunay}}, \code{\link{quantess}}, \code{\link{bufftess}} and \code{\link[spatstat.random]{rpoislinetess}}. } \author{ \adrian and \rolf } \keyword{utilities} \keyword{datagen} spatstat.geom/man/solutionset.Rd0000644000176200001440000000522714611065350016504 0ustar liggesusers\name{solutionset} \alias{solutionset} \title{Evaluate Logical Expression Involving Pixel Images and Return Region Where Expression is True} \description{ Given a logical expression involving one or more pixel images, find all pixels where the expression is true, and assemble these pixels into a window. } \usage{ solutionset(\dots, envir) } \arguments{ \item{\dots}{An expression in the \R language, involving one or more pixel images.} \item{envir}{Optional. The environment in which to evaluate the expression.} } \details{ Given a logical expression involving one or more pixel images, this function will find all pixels where the expression is true, and assemble these pixels into a spatial window. Pixel images in \code{spatstat} are represented by objects of class \code{"im"} (see \code{\link{im.object}}). These are essentially matrices of pixel values, with extra attributes recording the pixel dimensions, etc. Suppose \code{X} is a pixel image. Then \code{solutionset(abs(X) > 3)} will find all the pixels in \code{X} for which the pixel value is greater than 3 in absolute value, and return a window containing all these pixels. If \code{X} and \code{Y} are two pixel images, \code{solutionset(X > Y)} will find all pixels for which the pixel value of \code{X} is greater than the corresponding pixel value of \code{Y}, and return a window containing these pixels. In general, \code{\dots} can be any logical expression involving pixel images. The code first tries to evaluate the expression using \code{\link{eval.im}}. This is successful if the expression involves only (a) the \emph{names} of pixel images, (b) scalar constants, and (c) functions which are vectorised. There must be at least one pixel image in the expression. The expression \code{expr} must be vectorised. See the Examples. If this is unsuccessful, the code then tries to evaluate the expression using pixel arithmetic. This is successful if all the arithmetic operations in the expression are listed in \code{\link{Math.im}}. } \value{ A spatial window (object of class \code{"owin"}, see \code{\link{owin.object}}). } \seealso{ \code{\link{im.object}}, \code{\link{owin.object}}, \code{\link{eval.im}}, \code{\link{levelset}} } \examples{ # test images X <- as.im(function(x,y) { x^2 - y^2 }, unit.square()) Y <- as.im(function(x,y) { 3 * x + y - 1}, unit.square()) W <- solutionset(abs(X) > 0.1) W <- solutionset(X > Y) W <- solutionset(X + Y >= 1) area(solutionset(X < Y)) solutionset(distmap(cells) < 0.05) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{programming} \keyword{manip} spatstat.geom/man/inside.owin.Rd0000644000176200001440000000450714611065346016347 0ustar liggesusers\name{inside.owin} \alias{inside.owin} \title{Test Whether Points Are Inside A Window} \description{ Test whether points lie inside or outside a given window. } \usage{ inside.owin(x, y, w) } \arguments{ \item{x}{ Vector of \eqn{x} coordinates of points to be tested. (Alternatively, a point pattern object providing both \eqn{x} and \eqn{y} coordinates.) } \item{y}{ Vector of \eqn{y} coordinates of points to be tested. } \item{w}{A window. This should be an object of class \code{\link{owin}}, or can be given in any format acceptable to \code{\link{as.owin}()}. } } \value{ Logical vector whose \code{i}th entry is \code{TRUE} if the corresponding point \code{(x[i],y[i])} is inside \code{w}. } \details{ This function tests whether each of the points \code{(x[i],y[i])} lies inside or outside the window \code{w} and returns \code{TRUE} if it is inside. The boundary of the window is treated as being inside. If \code{w} is of type \code{"rectangle"} or \code{"polygonal"}, the algorithm uses analytic geometry (the discrete Stokes theorem). Computation time is linear in the number of points and (for polygonal windows) in the number of vertices of the boundary polygon. Boundary cases are correct to single precision accuracy. If \code{w} is of type \code{"mask"} then the pixel closest to \code{(x[i],y[i])} is tested. The results may be incorrect for points lying within one pixel diameter of the window boundary. Normally \code{x} and \code{y} must be numeric vectors of equal length (length zero is allowed) containing the coordinates of points. Alternatively \code{x} can be a point pattern (object of class \code{"ppp"}) while \code{y} is missing; then the coordinates of the point pattern are extracted. } \seealso{ \code{\link{owin.object}}, \code{\link{as.owin}} } \examples{ # hexagonal window k <- 6 theta <- 2 * pi * (0:(k-1))/k co <- cos(theta) si <- sin(theta) mas <- owin(c(-1,1), c(-1,1), poly=list(x=co, y=si)) if(human <- interactive()) { plot(mas) } # random points in rectangle x <- runif(30,min=-1, max=1) y <- runif(30,min=-1, max=1) ok <- inside.owin(x, y, mas) if(human) { points(x[ok], y[ok]) points(x[!ok], y[!ok], pch="x") } } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/shift.ppx.Rd0000644000176200001440000000265514611065350016041 0ustar liggesusers\name{shift.ppx} \alias{shift.ppx} \alias{shift.boxx} \title{Apply Vector Translation To Box Or Point Pattern In Arbitrary Dimension} \description{ Applies a vector shift to a box or point pattern in arbitrary dimension (object of class \code{"boxx"} or \code{"ppx"}). } \usage{ \method{shift}{boxx}(X, vec= 0, \dots) \method{shift}{ppx}(X, vec = 0, \dots, spatial = TRUE, temporal = TRUE, local = TRUE) } \arguments{ \item{X}{Box or point pattern in arbitrary dimension (object of class \code{"boxx"} or \code{"ppx"}).} \item{vec}{Either a single numeric or a vector of the same length as the dimension of the spatial and/or temporal and/or local domain.} \item{\dots}{Ignored} \item{spatial,temporal,local}{ Logical to indicate whether or not to shift this type of coordinates for the \code{ppx} method. } } \value{ For \code{shift.boxx}, another \code{"boxx"} object and for \code{shift.ppx} another \code{"ppx"} object. In both cases the new object represents the result of applying the vector shift. } \details{ This is a method for the generic function \code{\link{shift}}. } \seealso{ \code{\link{shift}}, \code{\link{boxx}}, \code{\link{ppx}} } \examples{ vec <- c(2,3) dom <- boxx(c(0,1), c(0,1)) X <- ppx(coords(cells), domain = dom) shift(dom, vec) Xs <- shift(X, vec) Xs head(coords(X), n = 3) head(coords(Xs), n = 3) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/is.marked.ppp.Rd0000644000176200001440000000337414611065346016575 0ustar liggesusers\name{is.marked.ppp} \alias{is.marked.ppp} \title{Test Whether A Point Pattern is Marked} \description{ Tests whether a point pattern has ``marks'' attached to the points. } \usage{ \method{is.marked}{ppp}(X, na.action="warn", \dots) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"}) } \item{na.action}{ String indicating what to do if \code{NA} values are encountered amongst the marks. Options are \code{"warn"}, \code{"fatal"} and \code{"ignore"}. } \item{\dots}{ Ignored. } } \value{ Logical value, equal to \code{TRUE} if \code{X} is a marked point pattern. } \details{ ``Marks'' are observations attached to each point of a point pattern. For example the \code{\link[spatstat.data]{longleaf}} dataset contains the locations of trees, each tree being marked by its diameter; the \code{\link[spatstat.data]{amacrine}} dataset gives the locations of cells of two types (on/off) and the type of cell may be regarded as a mark attached to the location of the cell. This function tests whether the point pattern \code{X} contains or involves marked points. It is a method for the generic function \code{\link{is.marked}}. The argument \code{na.action} determines what action will be taken if the point pattern has a vector of marks but some or all of the marks are \code{NA}. Options are \code{"fatal"} to cause a fatal error; \code{"warn"} to issue a warning and then return \code{TRUE}; and \code{"ignore"} to take no action except returning \code{TRUE}. } \seealso{ \code{\link{is.marked}}, \code{\link[spatstat.model]{is.marked.ppm}} } \examples{ is.marked(cells) #FALSE data(longleaf) is.marked(longleaf) #TRUE } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/distfun.Rd0000644000176200001440000001076014765164151015577 0ustar liggesusers\name{distfun} \Rdversion{1.1} \alias{distfun} \alias{distfun.ppp} \alias{distfun.psp} \alias{distfun.owin} \title{ Distance Map as a Function } \description{ Compute the distance function of an object, and return it as a function. } \usage{ distfun(X, \dots) \method{distfun}{ppp}(X, \dots, k=1, undef=Inf) \method{distfun}{psp}(X, \dots) \method{distfun}{owin}(X, \dots, invert=FALSE) } \arguments{ \item{X}{Any suitable dataset representing a two-dimensional object, such as a point pattern (object of class \code{"ppp"}), a window (object of class \code{"owin"}) or a line segment pattern (object of class \code{"psp"}). } \item{\dots}{ Extra arguments are ignored. } \item{k}{ An integer. The distance to the \code{k}th nearest point will be computed. } \item{undef}{ The value that should be returned if the distance is undefined (that is, if \code{X} contains fewer than \code{k} points). } \item{invert}{ If \code{TRUE}, compute the distance transform of the complement of \code{X}. } } \details{ The \dQuote{distance function} of a set of points \eqn{A} is the mathematical function \eqn{f} such that, for any two-dimensional spatial location \eqn{(x,y)}, the function value \code{f(x,y)} is the shortest distance from \eqn{(x,y)} to \eqn{A}. The command \code{f <- distfun(X)} returns a \emph{function} in the \R language, with arguments \code{x,y}, that represents the distance function of \code{X}. Evaluating the function \code{f} in the form \code{v <- f(x,y)}, where \code{x} and \code{y} are any numeric vectors of equal length containing coordinates of spatial locations, yields the values of the distance function at these locations. Alternatively \code{x} can be a point pattern (object of class \code{"ppp"} or \code{"lpp"}) of locations at which the distance function should be computed (and then \code{y} should be missing). This should be contrasted with the related command \code{\link{distmap}} which computes the distance function of \code{X} on a grid of locations, and returns the distance values in the form of a pixel image. The distance values returned by \code{f <- distfun(X); d <- f(x)} are computed using coordinate geometry; they are more accurate, but slower to compute, than the distance values returned by \code{Z <- distmap(X); d <- Z[x]} which are computed using a fast recursive algorithm. The result of \code{f <- distfun(X)} also belongs to the class \code{"funxy"} and to the special class \code{"distfun"}. It can be printed and plotted immediately as shown in the Examples. A \code{distfun} object can be converted to a pixel image using \code{\link{as.im}}. } \value{ A \code{function} with arguments \code{x,y}. The function belongs to the class \code{"distfun"} which has methods for \code{print} and \code{summary}, and for geometric operations like \code{shift}. It also belongs to the class \code{"funxy"} which has methods for \code{plot}, \code{contour} and \code{persp}. } \section{Distance values}{ The values returned by the distance function \code{f <- distfun(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{f} are expressed as multiples of 2 microns, rather than being expressed in microns. } \section{Domain of the function}{ The domain of the distance function is unbounded, that is, the distance function can be evaluated at any spatial location. However, when the distance function is plotted by \code{plot}, \code{contour} or \code{persp}, the function domain is assumed to be the rectangular frame surrounding the original object \code{X}. To generate a plot of the distance function on a different region, use the argument \code{W} in the plot command, as explained in the help for \code{\link{plot.funxy}}. } \seealso{ \code{\link{distmap}}, \code{\link{summary.distfun}}, \code{\link{methods.distfun}}, \code{\link{methods.funxy}}, \code{\link{plot.funxy}} } \examples{ f <- distfun(letterR) f plot(f) f(0.2, 0.3) plot(distfun(letterR, invert=TRUE), eps=0.1) d <- distfun(cells) d2 <- distfun(cells, k=2) d(0.5, 0.5) d2(0.5, 0.5) domain(d) summary(d) z <- d(japanesepines) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/print.owin.Rd0000644000176200001440000000152614611065350016221 0ustar liggesusers\name{print.owin} \alias{print.owin} \title{Print Brief Details of a Spatial Window} \description{ Prints a very brief description of a window object. } \usage{ \method{print}{owin}(x, \dots, prefix="window: ") } \arguments{ \item{x}{Window (object of class \code{"owin"}).} \item{\dots}{Ignored.} \item{prefix}{Character string to be printed at the start of the output.} } \details{ A very brief description of the window \code{x} is printed. This is a method for the generic function \code{\link{print}}. } \seealso{ \code{\link{print}}, \code{\link{print.ppp}}, \code{\link{summary.owin}} } \examples{ owin() # the unit square W <- Window(demopat) W # just says it is polygonal as.mask(W) # just says it is a binary image } \author{\adrian and \rolf } \keyword{spatial} \keyword{print} spatstat.geom/man/affine.psp.Rd0000644000176200001440000000340614611065345016146 0ustar liggesusers\name{affine.psp} \alias{affine.psp} \title{Apply Affine Transformation To Line Segment Pattern} \description{ Applies any affine transformation of the plane (linear transformation plus vector shift) to a line segment pattern. } \usage{ \method{affine}{psp}(X, mat=diag(c(1,1)), vec=c(0,0), \dots) } \arguments{ \item{X}{Line Segment pattern (object of class \code{"psp"}).} \item{mat}{Matrix representing a linear transformation.} \item{vec}{Vector of length 2 representing a translation.} \item{\dots}{Arguments passed to \code{\link{affine.owin}} affecting the handling of the observation window, if it is a binary pixel mask. } } \value{ Another line segment pattern (of class \code{"psp"}) representing the result of applying the affine transformation. } \details{ The line segment pattern, and its window, are subjected first to the linear transformation represented by \code{mat} (multiplying on the left by \code{mat}), and are then translated by the vector \code{vec}. The argument \code{mat} must be a nonsingular \eqn{2 \times 2}{2 * 2} matrix. This is a method for the generic function \code{\link{affine}}. } \seealso{ \code{\link{affine}}, \code{\link{affine.owin}}, \code{\link{affine.ppp}}, \code{\link{affine.im}}, \code{\link{flipxy}}, \code{\link{rotate}}, \code{\link{shift}} } \examples{ oldpar <- par(mfrow=c(2,1)) X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) plot(X, main="original") # shear transformation Y <- affine(X, matrix(c(1,0,0.6,1),ncol=2)) plot(Y, main="transformed") par(oldpar) # # rescale y coordinates by factor 0.2 affine(X, diag(c(1,0.2))) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} \concept{Geometrical transformations} spatstat.geom/man/round.ppp.Rd0000644000176200001440000000216614642117031016036 0ustar liggesusers\name{round.ppp} \alias{round.ppp} \alias{round.pp3} \alias{round.ppx} \title{ Apply Numerical Rounding to Spatial Coordinates } \description{ Apply numerical rounding to the spatial coordinates of a point pattern. } \usage{ \method{round}{ppp}(x, digits = 0, \dots) \method{round}{pp3}(x, digits = 0, \dots) \method{round}{ppx}(x, digits = 0, \dots) } \arguments{ \item{x}{ A spatial point pattern in any dimension (object of class \code{"ppp"}, \code{"pp3"} or \code{"ppx"}). } \item{digits}{ integer indicating the number of decimal places. } \item{\dots}{Additional arguments passed to the default method.} } \details{ These functions are methods for the generic function \code{\link[base]{round}}. They apply numerical rounding to the spatial coordinates of the point pattern \code{x}. } \value{ A point pattern object, of the same class as \code{x}. } \author{ \adrian and \rolf } \seealso{ \code{\link{rounding.ppp}} to determine whether numbers have been rounded. \code{\link[base]{round}} in the Base package. } \examples{ round(cells, 1) } \keyword{spatial} \keyword{manip} spatstat.geom/man/boxx.Rd0000644000176200001440000000234714611065345015100 0ustar liggesusers\name{boxx} \Rdversion{1.1} \alias{boxx} \title{ Multi-Dimensional Box } \description{ Creates an object representing a multi-dimensional box. } \usage{ boxx(..., unitname = NULL) } \arguments{ \item{\dots}{ Dimensions of the box. Vectors of length 2. } \item{unitname}{ Optional. Name of the unit of length. See Details. } } \details{ This function creates an object representing a multi-dimensional rectangular parallelepiped (box) with sides parallel to the coordinate axes. The object can be used to specify the domain of a multi-dimensional point pattern (see \code{\link{ppx}}) and in various geometrical calculations (see \code{\link{volume.boxx}}, \code{\link{diameter.boxx}}, \code{\link{eroded.volumes}}). The optional argument \code{unitname} specifies the name of the unit of length. See \code{\link{unitname}} for valid formats. } \value{ An object of class \code{"boxx"}. There is a print method for this class. } \author{ \spatstatAuthors. } \seealso{ \code{\link{ppx}}, \code{\link{volume.boxx}}, \code{\link{diameter.boxx}}, \code{\link{eroded.volumes.boxx}}. } \examples{ boxx(c(0,10),c(0,10),c(0,5),c(0,1), unitname=c("metre","metres")) } \keyword{spatial} \keyword{datagen} spatstat.geom/man/nobjects.Rd0000644000176200001440000000226114611065347015724 0ustar liggesusers\name{nobjects} \alias{nobjects} \alias{nobjects.ppp} \alias{nobjects.ppx} \alias{nobjects.psp} \alias{nobjects.tess} \title{ Count Number of Geometrical Objects in a Spatial Dataset } \description{ A generic function to count the number of geometrical objects in a spatial dataset. } \usage{ nobjects(x) \method{nobjects}{ppp}(x) \method{nobjects}{ppx}(x) \method{nobjects}{psp}(x) \method{nobjects}{tess}(x) } \arguments{ \item{x}{A dataset.} } \details{ The generic function \code{nobjects} counts the number of geometrical objects in the spatial dataset \code{x}. The methods for point patterns (classes \code{"ppp"} and \code{"ppx"}, embracing \code{"pp3"} and \code{"lpp"}) count the number of points in the pattern. The method for line segment patterns (class \code{"psp"}) counts the number of line segments in the pattern. The method for tessellations (class \code{"tess"}) counts the number of tiles of the tessellation. } \value{ A single integer. } \author{ \spatstatAuthors } \seealso{ \code{\link{npoints}} } \examples{ nobjects(redwood) nobjects(edges(letterR)) nobjects(dirichlet(cells)) } \keyword{spatial} \keyword{manip} spatstat.geom/man/domain.Rd0000644000176200001440000000432014643111575015362 0ustar liggesusers\name{domain} \alias{domain} \alias{domain.ppp} \alias{domain.psp} \alias{domain.im} \alias{domain.ppx} \alias{domain.pp3} \alias{domain.quad} \alias{domain.quadratcount} \alias{domain.tess} \alias{domain.layered} \alias{domain.distfun} \alias{domain.nnfun} \alias{domain.funxy} \title{ Extract the Domain of any Spatial Object } \description{ Given a spatial object such as a point pattern, in any number of dimensions, this function extracts the spatial domain in which the object is defined. } \usage{ domain(X, \dots) \method{domain}{ppp}(X, \dots) \method{domain}{psp}(X, \dots) \method{domain}{im}(X, \dots) \method{domain}{ppx}(X, \dots) \method{domain}{pp3}(X, \dots) \method{domain}{quad}(X, \dots) \method{domain}{quadratcount}(X, \dots) \method{domain}{tess}(X, \dots) \method{domain}{layered}(X, \dots) \method{domain}{distfun}(X, \dots) \method{domain}{nnfun}(X, \dots) \method{domain}{funxy}(X, \dots) } \arguments{ \item{X}{ A spatial object such as a point pattern (in any number of dimensions), line segment pattern or pixel image. } \item{\dots}{ Extra arguments. They are ignored by all the methods listed here. } } \details{ The function \code{\link[spatstat.geom]{domain}} is generic. For a spatial object \code{X} in any number of dimensions, \code{domain(X)} extracts the spatial domain in which \code{X} is defined. For a two-dimensional object \code{X}, typically \code{domain(X)} is the same as \code{Window(X)}. Exceptions occur for methods related to linear networks. } \value{ A spatial object representing the domain of \code{X}. Typically a window (object of class \code{"owin"}), a three-dimensional box (\code{"box3"}), a multidimensional box (\code{"boxx"}) or a linear network (\code{"linnet"}). } \author{ \spatstatAuthors. } \seealso{ \code{\link[spatstat.model]{domain.ppm}}, \code{\link[spatstat.explore]{domain.quadrattest}}, \code{\link[spatstat.random]{domain.rmhmodel}}, \code{\link[spatstat.linnet]{domain.lpp}}. \code{\link[spatstat.geom]{Window}}, \code{\link[spatstat.geom]{Frame}}. } \examples{ domain(redwood) domain(bei.extra$elev) domain(osteo$pts[[1]]) } \keyword{spatial} \keyword{manip} spatstat.geom/man/endpoints.psp.Rd0000644000176200001440000000503414611065346016721 0ustar liggesusers\name{endpoints.psp} \alias{endpoints.psp} \title{Endpoints of Line Segment Pattern} \description{ Extracts the endpoints of each line segment in a line segment pattern. } \usage{ endpoints.psp(x, which="both") } \arguments{ \item{x}{ A line segment pattern (object of class \code{"psp"}). } \item{which}{ String specifying which endpoint or endpoints should be returned. See Details. } } \value{ Point pattern (object of class \code{"ppp"}). } \details{ This function extracts one endpoint, or both endpoints, from each of the line segments in \code{x}, and returns these points as a point pattern object. The argument \code{which} determines which endpoint or endpoints of each line segment should be returned: \describe{ \item{\code{which="both"}}{ (the default): both endpoints of each line segment are returned. The result is a point pattern with twice as many points as there are line segments in \code{x}. } \item{\code{which="first"}}{ select the first endpoint of each line segment (returns the points with coordinates \code{x$ends$x0, x$ends$y0}). } \item{\code{which="second"}}{ select the second endpoint of each line segment (returns the points with coordinates \code{x$ends$x1, x$ends$y1}). } \item{\code{which="left"}}{ select the left-most endpoint (the endpoint with the smaller \eqn{x} coordinate) of each line segment. } \item{\code{which="right"}}{ select the right-most endpoint (the endpoint with the greater \eqn{x} coordinate) of each line segment. } \item{\code{which="lower"}}{ select the lower endpoint (the endpoint with the smaller \eqn{y} coordinate) of each line segment. } \item{\code{which="upper"}}{ select the upper endpoint (the endpoint with the greater \eqn{y} coordinate) of each line segment. } } The result is a point pattern. It also has an attribute \code{"id"} which is an integer vector identifying the segment which contributed each point. } \seealso{ \code{\link{psp.object}}, \code{\link{ppp.object}}, \code{\link{marks.psp}}, \code{\link{summary.psp}}, \code{\link{midpoints.psp}}, \code{\link{lengths_psp}}, \code{\link{angles.psp}}, \code{\link{extrapolate.psp}}. } \examples{ a <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) plot(a) b <- endpoints.psp(a, "left") plot(b, add=TRUE) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/multiplicity.ppp.Rd0000644000176200001440000000403414611065347017443 0ustar liggesusers\name{multiplicity.ppp} \alias{multiplicity} \alias{multiplicity.default} \alias{multiplicity.data.frame} \alias{multiplicity.ppp} \alias{multiplicity.ppx} \title{Count Multiplicity of Duplicate Points} \description{ Counts the number of duplicates for each point in a spatial point pattern. } \usage{ multiplicity(x) \method{multiplicity}{ppp}(x) \method{multiplicity}{ppx}(x) \method{multiplicity}{data.frame}(x) \method{multiplicity}{default}(x) } \arguments{ \item{x}{ A spatial point pattern (object of class \code{"ppp"} or \code{"ppx"}) or a vector, matrix or data frame. } } \value{ A vector of integers (multiplicities) of length equal to the number of points in \code{x}. } \details{ Two points in a point pattern are deemed to be identical if their \eqn{x,y} coordinates are the same, and their marks are also the same (if they carry marks). The Examples section illustrates how it is possible for a point pattern to contain a pair of identical points. For each point in \code{x}, the function \code{multiplicity} counts how many points are identical to it, and returns the vector of counts. The argument \code{x} can also be a vector, a matrix or a data frame. When \code{x} is a vector, \code{m <- multiplicity(x)} is a vector of the same length as \code{x}, and \code{m[i]} is the number of elements of \code{x} that are identical to \code{x[i]}. When \code{x} is a matrix or data frame, \code{m <- multiplicity(x)} is a vector of length equal to the number of rows of \code{x}, and \code{m[i]} is the number of rows of \code{x} that are identical to the \code{i}th row. } \seealso{ \code{\link{ppp.object}}, \code{\link{duplicated.ppp}}, \code{\link{unique.ppp}} } \examples{ X <- ppp(c(1,1,0.5,1), c(2,2,1,2), window=square(3), check=FALSE) m <- multiplicity(X) # unique points in X, marked by their multiplicity first <- !duplicated(X) Y <- X[first] \%mark\% m[first] } \author{\adrian , \rolf and Sebastian Meyer. } \keyword{spatial} \keyword{utilities} spatstat.geom/man/clickpoly.Rd0000644000176200001440000000410514611065345016103 0ustar liggesusers\name{clickpoly} \alias{clickpoly} \title{Interactively Define a Polygon} \description{ Allows the user to create a polygon by point-and-click in the display. } \usage{ clickpoly(add=FALSE, nv=NULL, np=1, \dots) } \arguments{ \item{add}{ Logical value indicating whether to create a new plot (\code{add=FALSE}) or draw over the existing plot (\code{add=TRUE}). } \item{nv}{ Number of vertices of the polygon (if this is predetermined). } \item{np}{ Number of polygons to create. } \item{\dots}{ Arguments passed to \code{\link[graphics]{locator}} to control the interactive plot, and to \code{\link[graphics]{polygon}} to plot the polygons. } } \value{ A window (object of class \code{"owin"}) representing the polygon. } \details{ This function allows the user to create a polygonal window by interactively clicking on the screen display. The user is prompted to point the mouse at any desired locations for the polygon vertices, and click the left mouse button to add each point. Interactive input stops after \code{nv} clicks (if \code{nv} was given) or when the middle mouse button is pressed. The return value is a window (object of class \code{"owin"}) representing the polygon. This function uses the \R command \code{\link[graphics]{locator}} to input the mouse clicks. It only works on screen devices such as \sQuote{X11}, \sQuote{windows} and \sQuote{quartz}. Arguments that can be passed to \code{\link[graphics]{locator}} through \code{\dots} include \code{pch} (plotting character), \code{cex} (character expansion factor) and \code{col} (colour). See \code{\link[graphics]{locator}} and \code{\link[graphics]{par}}. Multiple polygons can also be drawn, by specifying \code{np > 1}. The polygons must be disjoint. The result is a single window object consisting of all the polygons. } \seealso{ \code{\link{identify.ppp}}, \code{\link{clickbox}}, \code{\link{clickppp}}, \code{\link{clickdist}}, \code{\link[graphics]{locator}} } \author{ \adrian and \rolf. } \keyword{spatial} \keyword{iplot} spatstat.geom/man/runifrect.Rd0000644000176200001440000000350714611065350016114 0ustar liggesusers\name{runifrect} \alias{runifrect} \title{Generate N Uniform Random Points in a Rectangle} \description{ Generate a random point pattern, containing \eqn{n} independent uniform random points, inside a specified rectangle. } \usage{ runifrect(n, win = owin(c(0, 1), c(0, 1)), nsim = 1, drop = TRUE) } \arguments{ \item{n}{ Number of points. } \item{win}{ Rectangular window in which to simulate the pattern. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}, which must specify a rectangle. } \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } } \details{ This function is a slightly faster version of \code{\link[spatstat.random]{runifpoint}} for the special case where the window is a rectangle. The function generates \code{n} independent random points, uniformly distributed in the window \code{win}, by assigning uniform random values to the cartesian coordinates. For normal usage we recommend \code{\link[spatstat.random]{runifpoint}} because it is more flexible. However, \code{runifrect} is slightly faster (when the window is a rectangle), and may be preferable in very computationally-demanding tasks. } \value{ A point pattern (an object of class \code{"ppp"}) if \code{nsim=1} and \code{drop=TRUE}, otherwise a list of point patterns. } \seealso{ \code{\link{ppp.object}}, \code{\link{owin.object}}, \code{\link[spatstat.random]{runifpoint}}, \code{\link[spatstat.random]{rpoispp}}, \code{\link[spatstat.random]{rpoint}} } \examples{ # 42 random points in the unit square pp <- runifrect(42) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/solist.Rd0000644000176200001440000000644314611065350015432 0ustar liggesusers\name{solist} \alias{solist} \title{ List of Two-Dimensional Spatial Objects } \description{ Make a list of two-dimensional spatial objects. } \usage{ solist(\dots, check=TRUE, promote=TRUE, demote=FALSE, .NameBase) } \arguments{ \item{\dots}{ Any number of objects, each representing a two-dimensional spatial dataset. } \item{check}{ Logical value. If \code{TRUE}, check that each of the objects is a 2D spatial object. } \item{promote}{ Logical value. If \code{TRUE}, test whether all objects belong to the \emph{same} class, and if so, promote the list of objects to the appropriate class of list. } \item{demote}{ Logical value determining what should happen if any of the objects is not a 2D spatial object: if \code{demote=FALSE} (the default), a fatal error occurs; if \code{demote=TRUE}, a list of class \code{"anylist"} is returned. } \item{.NameBase}{ Optional. Character string. If the \code{\dots} arguments have no names, then the entries of the resulting list will be given names that start with \code{.NameBase}. } } \details{ This command creates an object of class \code{"solist"} (spatial object list) which represents a list of two-dimensional spatial datasets. The datasets do not necessarily belong to the same class. Typically the intention is that the datasets in the list should be treated in the same way, for example, they should be plotted side-by-side. The \pkg{spatstat} package provides a plotting function, \code{\link{plot.solist}}, and many other functions for this class. In the \pkg{spatstat} package, various functions produce an object of class \code{"solist"}. For example, when a point pattern is split into several point patterns by \code{\link{split.ppp}}, or an image is split into several images by \code{\link{split.im}}, the result is of class \code{"solist"}. If \code{check=TRUE} then the code will check whether all objects in \code{\dots} belong to the classes of two-dimensional spatial objects defined in the \pkg{spatstat} package. They do not have to belong to the \emph{same} class. Set \code{check=FALSE} for efficiency, but only if you are sure that all the objects are valid. If some of the objects in \code{\dots} are not two-dimensional spatial objects, the action taken depends on the argument \code{demote}. If \code{demote=TRUE}, the result will belong to the more general class \code{"anylist"} instead of \code{"solist"}. If \code{demote=FALSE} (the default), an error occurs. If \code{promote=TRUE} then the code will check whether all the objects \code{\dots} belong to the same class. If they are all point patterns (class \code{"ppp"}), the result will also belong to the class \code{"ppplist"}. If they are all pixel images (class \code{"im"}), the result will also belong to the class \code{"imlist"}. Use \code{\link{as.solist}} to convert a list to a \code{"solist"}. } \value{ A list, usually belonging to the class \code{"solist"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{as.solist}}, \code{\link{anylist}}, \code{\link{solapply}} } \examples{ solist(cells, distmap(cells), quadratcount(cells)) solist(cells, japanesepines, redwood, .NameBase="Pattern") } \keyword{spatial} \keyword{list} \keyword{manip} spatstat.geom/man/area.owin.Rd0000644000176200001440000000323214611065345015775 0ustar liggesusers\name{area.owin} \alias{area} \alias{area.owin} \alias{area.default} \alias{volume.owin} \title{Area of a Window} \description{ Computes the area of a window } \usage{ area(w) \method{area}{owin}(w) \method{area}{default}(w) \method{volume}{owin}(x) } \arguments{ \item{w}{A window, whose area will be computed. This should be an object of class \code{\link{owin}}, or can be given in any format acceptable to \code{\link{as.owin}()}. } \item{x}{Object of class \code{\link{owin}}} } \value{ A numerical value giving the area of the window. } \details{ If the window \code{w} is of type \code{"rectangle"} or \code{"polygonal"}, the area of this rectangular window is computed by analytic geometry. If \code{w} is of type \code{"mask"} the area of the discrete raster approximation of the window is computed by summing the binary image values and adjusting for pixel size. The function \code{volume.owin} is identical to \code{area.owin} except for the argument name. It is a method for the generic function \code{volume}. } \seealso{ \code{\link{perimeter}}, \code{\link{diameter.owin}}, \code{\link{owin.object}}, \code{\link{as.owin}} } \examples{ w <- unit.square() area(w) # returns 1.00000 k <- 6 theta <- 2 * pi * (0:(k-1))/k co <- cos(theta) si <- sin(theta) mas <- owin(c(-1,1), c(-1,1), poly=list(x=co, y=si)) area(mas) # returns approx area of k-gon mas <- as.mask(square(2), eps=0.01) X <- raster.x(mas) Y <- raster.y(mas) mas$m <- ((X - 1)^2 + (Y - 1)^2 <= 1) area(mas) # returns 3.14 approx } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/closepairs.pp3.Rd0000644000176200001440000001034614611065345016763 0ustar liggesusers\name{closepairs.pp3} \alias{closepairs.pp3} \alias{crosspairs.pp3} \title{ Close Pairs of Points in 3 Dimensions } \description{ Low-level functions to find all close pairs of points in three-dimensional point patterns. } \usage{ \method{closepairs}{pp3}(X, rmax, twice=TRUE, what=c("all", "indices", "ijd"), distinct=TRUE, neat=TRUE, \dots) \method{crosspairs}{pp3}(X, Y, rmax, what=c("all", "indices", "ijd"), \dots) } \arguments{ \item{X,Y}{ Point patterns in three dimensions (objects of class \code{"pp3"}). } \item{rmax}{ Maximum distance between pairs of points to be counted as close pairs. } \item{twice}{ Logical value indicating whether all ordered pairs of close points should be returned. If \code{twice=TRUE}, each pair will appear twice in the output, as \code{(i,j)} and again as \code{(j,i)}. If \code{twice=FALSE}, then each pair will appear only once, as the pair \code{(i,j)} such that \code{i < j}. } \item{what}{ String specifying the data to be returned for each close pair of points. If \code{what="all"} (the default) then the returned information includes the indices \code{i,j} of each pair, their \code{x,y,z} coordinates, and the distance between them. If \code{what="indices"} then only the indices \code{i,j} are returned. If \code{what="ijd"} then the indices \code{i,j} and the distance \code{d} are returned. } \item{distinct}{ Logical value indicating whether to return only the pairs of points with different indices \code{i} and \code{j} (\code{distinct=TRUE}, the default) or to also include the pairs where \code{i=j} (\code{distinct=FALSE}). } \item{neat}{ Logical value indicating whether to ensure that \code{i < j} in each output pair, when \code{twice=FALSE}. } \item{\dots}{Ignored.} } \details{ These are the efficient low-level functions used by \pkg{spatstat} to find all close pairs of points in a three-dimensional point pattern or all close pairs between two point patterns in three dimensions. \code{closepairs(X,rmax)} identifies all pairs of neighbours in the pattern \code{X} and returns them. The result is a list with the following components: \describe{ \item{i}{Integer vector of indices of the first point in each pair.} \item{j}{Integer vector of indices of the second point in each pair.} \item{xi,yi,zi}{Coordinates of the first point in each pair.} \item{xj,yj,zj}{Coordinates of the second point in each pair.} \item{dx}{Equal to \code{xj-xi}} \item{dy}{Equal to \code{yj-yi}} \item{dz}{Equal to \code{zj-zi}} \item{d}{Euclidean distance between each pair of points.} } If \code{what="indices"} then only the components \code{i} and \code{j} are returned. This is slightly faster. \code{crosspairs(X,rmax)} identifies all pairs of neighbours \code{(X[i], Y[j])} between the patterns \code{X} and \code{Y}, and returns them. The result is a list with the same format as for \code{closepairs}. } \section{Warning about accuracy}{ The results of these functions may not agree exactly with the correct answer (as calculated by a human) and may not be consistent between different computers and different installations of \R. The discrepancies arise in marginal cases where the interpoint distance is equal to, or very close to, the threshold \code{rmax}. Floating-point numbers in a computer are not mathematical Real Numbers: they are approximations using finite-precision binary arithmetic. The approximation is accurate to a tolerance of about \code{.Machine$double.eps}. If the true interpoint distance \eqn{d} and the threshold \code{rmax} are equal, or if their difference is no more than \code{.Machine$double.eps}, the result may be incorrect. } \value{ A list with components \code{i} and \code{j}, and possibly other components as described under Details. } \author{\adrian , \rolf and \ege. } \seealso{ \code{\link{closepairs}} } \examples{ X <- pp3(runif(10), runif(10), runif(10), box3(c(0,1))) Y <- pp3(runif(10), runif(10), runif(10), box3(c(0,1))) a <- closepairs(X, 0.1) b <- crosspairs(X, Y, 0.1) } \keyword{spatial} \keyword{math} \concept{Three-dimensional} spatstat.geom/man/requireversion.Rd0000644000176200001440000000233614611065350017174 0ustar liggesusers\name{requireversion} \alias{requireversion} \title{ Require a Specific Version of a Package } \description{ Checks that the version number of a specified package is greater than or equal to the specified version number. For use in stand-alone \R scripts. } \usage{ requireversion(pkg, ver, fatal=TRUE) } \arguments{ \item{pkg}{ Package name. } \item{ver}{ Character string containing version number. } \item{fatal}{ Logical value indicating whether an error should occur when the package version is less than \code{ver}. } } \details{ This function checks whether the installed version of the package \code{pkg} is greater than or equal to \code{ver}. By default, an error occurs if this condition is not met. It is useful in stand-alone \R scripts, which often require a particular version of a package in order to work correctly. \bold{This function should not be used inside a package}: for that purpose, the dependence on packages and versions should be specified in the package description file. } \value{ A logical value. } \author{ \adrian } \examples{ requireversion(spatstat.geom, "1.42-0") requireversion(spatstat.data, "999.999-999", fatal=FALSE) } \keyword{environment} spatstat.geom/man/crossing.psp.Rd0000644000176200001440000000425214611065345016545 0ustar liggesusers\name{crossing.psp} \alias{crossing.psp} \title{Crossing Points of Two Line Segment Patterns} \description{ Finds any crossing points between two line segment patterns. } \usage{ crossing.psp(A,B,fatal=TRUE,details=FALSE) } \arguments{ \item{A,B}{ Line segment patterns (objects of class \code{"psp"}). } \item{details}{ Logical value indicating whether to return additional information. See below. } \item{fatal}{ Logical value indicating what to do if the windows of \code{A} and \code{B} do not overlap. See Details. } } \value{ Point pattern (object of class \code{"ppp"}). } \details{ This function finds any crossing points between the line segment patterns \code{A} and \code{B}. A crossing point occurs whenever one of the line segments in \code{A} intersects one of the line segments in \code{B}, at a nonzero angle of intersection. The result is a point pattern consisting of all the intersection points. If \code{details=TRUE}, additional information is computed, specifying where each intersection point came from. The resulting point pattern has a data frame of marks, with columns named \code{iA, jB, tA, tB}. The marks \code{iA} and \code{jB} are the indices of the line segments in \code{A} and \code{B}, respectively, which produced each intersection point. The marks \code{tA} and \code{tB} are numbers between 0 and 1 specifying the position of the intersection point along the original segments. If the windows \code{Window(A)} and \code{Window(B)} do not overlap, then an error will be reported if \code{fatal=TRUE}, while if \code{fatal=FALSE} an error will not occur and the result will be \code{NULL}. } \seealso{ \code{\link{selfcrossing.psp}}, \code{\link{psp.object}}, \code{\link{ppp.object}}. } \examples{ a <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) b <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) plot(a, col="green", main="crossing.psp") plot(b, add=TRUE, col="blue") P <- crossing.psp(a,b) plot(P, add=TRUE, col="red") as.data.frame(crossing.psp(a,b,details=TRUE)) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/dirichletAreas.Rd0000644000176200001440000000173514611065346017044 0ustar liggesusers\name{dirichletAreas} \alias{dirichletAreas} \title{ Compute Areas of Tiles in Dirichlet Tessellation } \description{ Calculates the area of each tile in the Dirichlet-Voronoi tessellation of a point pattern. } \usage{ dirichletAreas(X) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"}). } } \details{ This is an efficient algorithm to calculate the areas of the tiles in the Dirichlet-Voronoi tessellation. If the window of \code{X} is a binary pixel mask, the tile areas are computed by counting pixels. Otherwise the areas are computed exactly using analytic geometry. If any points of \code{X} are duplicated, the duplicates will have tile area zero. } \value{ Numeric vector with one entry for each point of \code{X}. } \author{ \adrian \rolf and \ege } \seealso{ \code{\link{dirichlet}}, \code{\link{dirichletVertices}} } \examples{ aa <- dirichletAreas(cells) } \keyword{spatial} \keyword{math} \keyword{manip} spatstat.geom/man/shift.im.Rd0000644000176200001440000000446414611065350015637 0ustar liggesusers\name{shift.im} \alias{shift.im} \title{Apply Vector Translation To Pixel Image} \description{ Applies a vector shift to a pixel image } \usage{ \method{shift}{im}(X, vec=c(0,0), \dots, origin=NULL) } \arguments{ \item{X}{Pixel image (object of class \code{"im"}).} \item{vec}{Vector of length 2 representing a translation.} \item{\dots}{Ignored} \item{origin}{ Location that will be shifted to the origin. Either a numeric vector of length 2 giving the location, or a point pattern containing only one point, or a list with two entries named \code{x} and \code{y}, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). } } \value{ Another pixel image (of class \code{"im"}) representing the result of applying the vector shift. } \details{ The spatial location of each pixel in the image is translated by the vector \code{vec}. This is a method for the generic function \code{\link{shift}}. If \code{origin} is given, the argument \code{vec} will be ignored; instead the shift will be performed so that the specified geometric location is shifted to the coordinate origin \eqn{(0,0)}. The argument \code{origin} should be either a numeric vector of length 2 giving the spatial coordinates of a location, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). If \code{origin="centroid"} then the centroid of the window will be shifted to the origin. If \code{origin="midpoint"} then the centre of the bounding rectangle of the window will be shifted to the origin. If \code{origin="bottomleft"} then the bottom left corner of the bounding rectangle of the window will be shifted to the origin, and so on. } \seealso{ \code{\link{shift}} } \examples{ # make up an image X <- setcov(unit.square()) plot(X) Y <- shift(X, c(10,10)) plot(Y) # no discernible difference except coordinates are different shift(X, origin="c") } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.matrix.im.Rd0000644000176200001440000000230514611065345016424 0ustar liggesusers\name{as.matrix.im} \alias{as.matrix.im} \alias{as.array.im} \title{Convert Pixel Image to Matrix or Array} \description{ Converts a pixel image to a matrix or an array. } \usage{ \method{as.matrix}{im}(x, ...) \method{as.array}{im}(x, ...) } \arguments{ \item{x}{A pixel image (object of class \code{"im"}).} \item{\dots}{See below.} } \details{ The function \code{as.matrix.im} converts the pixel image \code{x} into a matrix containing the pixel values. It is handy when you want to extract a summary of the pixel values. See the Examples. The function \code{as.array.im} converts the pixel image to an array. By default this is a three-dimensional array of dimension \eqn{n} by \eqn{m} by \eqn{1}. If the extra arguments \code{\dots} are given, they will be passed to \code{\link{array}}, and they may change the dimensions of the array. } \value{ A matrix or array. } \seealso{ \code{\link{as.matrix.owin}} } \examples{ # artificial image Z <- setcov(square(1)) M <- as.matrix(Z) median(M) # plot the cumulative distribution function of pixel values # plot(ecdf(as.matrix(Z))) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/rlinegrid.Rd0000644000176200001440000000160014611065350016062 0ustar liggesusers\name{rlinegrid} \alias{rlinegrid} \title{Generate grid of parallel lines with random displacement} \description{ Generates a grid of parallel lines, equally spaced, inside the specified window. } \usage{ rlinegrid(angle = 45, spacing = 0.1, win = owin()) } \arguments{ \item{angle}{Common orientation of the lines, in degrees anticlockwise from the x axis. } \item{spacing}{Spacing between successive lines.} \item{win}{Window in which to generate the lines. An object of class \code{"owin"} or something acceptable to \code{\link{as.owin}}. } } \details{ The grid is randomly displaced from the origin. } \value{ A line segment pattern (object of class \code{"psp"}). } \seealso{ \code{\link{psp}}, \code{\link[spatstat.random]{rpoisline}} } \examples{ plot(rlinegrid(30, 0.05)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/commonGrid.Rd0000644000176200001440000000366414643111575016223 0ustar liggesusers\name{commonGrid} \alias{commonGrid} \title{Determine A Common Spatial Domain And Pixel Resolution} \description{ Determine a common spatial domain and pixel resolution for several spatial objects such as images, masks, windows and point patterns. } \usage{ commonGrid(\dots) } \arguments{ \item{\dots}{ Any number of pixel images (objects of class \code{"im"}), binary masks (objects of class \code{"owin"} of type \code{"mask"}) or data which can be converted to binary masks by \code{\link[spatstat.geom]{as.mask}}. } } \details{ This function determines a common spatial resolution and spatial domain for several spatial objects. The arguments \code{\dots} may be pixel images, binary masks, or other spatial objects acceptable to \code{\link[spatstat.geom]{as.mask}}. The common pixel grid is determined by inspecting all the pixel images and binary masks in the argument list, finding the pixel grid with the highest spatial resolution, and extending this pixel grid to cover the bounding box of all the spatial objects. The return value is a binary mask \code{M}, representing the bounding box at the chosen pixel resolution. Use \code{\link{as.im}(X, W=M)} to convert a pixel image \code{X} to this new pixel resolution. Use \code{\link[spatstat.geom]{as.mask}(W, xy=M)} to convert a window \code{W} to a binary mask at this new pixel resolution. See the Examples. } \value{ A binary mask (object of class \code{"owin"} and type \code{"mask"}). } \author{ \adrian and \rolf } \examples{ if(require(spatstat.random)) { A <- setcov(square(1), dimyx=32) G <- as.im(function(x,y) { x^2 - y }, W=owin(), dimyx=8) H <- commonGrid(A, letterR, G) newR <- as.mask(letterR, xy=H) newG <- as.im(G, W=H) if(interactive()) plot(solist(G=newG, R=newR), main="") } } \seealso{ \code{\link{harmonise.im}}, \code{\link{compatible.im}}, \code{\link{as.im}} } \keyword{spatial} \keyword{manip} spatstat.geom/man/timeTaken.Rd0000644000176200001440000000214614611065351016033 0ustar liggesusers\name{timeTaken} \alias{timeTaken} \title{ Extract the Total Computation Time } \description{ Given an object or objects that contain timing information (reporting the amount of computer time taken to compute each object), this function extracts the timing data and evaluates the total time taken. } \usage{ timeTaken(..., warn=TRUE) } \arguments{ \item{\dots}{ One or more objects of class \code{"timed"} containing timing data. } \item{warn}{ Logical value indicating whether a warning should be issued if some of the arguments do not contain timing information. } } \details{ An object of class \code{"timed"} contains information on the amount of computer time that was taken to compute the object. See \code{\link{timed}}. This function extracts the timing information from one or more such objects, and calculates the total time. } \value{ An object inheriting the class \code{"timed"}. } \examples{ A <- timed(minnndist(bei)) B <- timed(minnndist(redwood)) A B timeTaken(A,B) } \seealso{ \code{\link{timed}} } \author{ \spatstatAuthors. } \keyword{utilities} spatstat.geom/man/is.empty.Rd0000644000176200001440000000224214611065346015663 0ustar liggesusers\name{is.empty} \alias{is.empty} \alias{is.empty.owin} \alias{is.empty.ppp} \alias{is.empty.psp} \alias{is.empty.default} \title{Test Whether An Object Is Empty} \description{ Checks whether the argument is an empty window, an empty point pattern, etc. } \usage{ is.empty(x) \method{is.empty}{owin}(x) \method{is.empty}{ppp}(x) \method{is.empty}{psp}(x) \method{is.empty}{default}(x) } \arguments{ \item{x}{ A window (object of class \code{"owin"}), a point pattern (object of class \code{"ppp"}), or a line segment pattern (object of class \code{"psp"}). } } \details{ This function tests whether the object \code{x} represents an empty spatial object, such as an empty window, a point pattern with zero points, or a line segment pattern with zero line segments. An empty window can be obtained as the output of \code{\link{intersect.owin}}, \code{\link{erosion}}, \code{\link{opening}}, \code{\link{complement.owin}} and some other operations. An empty point pattern or line segment pattern can be obtained as the result of simulation. } \value{ Logical value. } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/layerplotargs.Rd0000644000176200001440000000331614611065347017007 0ustar liggesusers\name{layerplotargs} \alias{layerplotargs} \alias{layerplotargs<-} \title{ Extract or Replace the Plot Arguments of a Layered Object } \description{ Extracts or replaces the plot arguments of a layered object. } \usage{ layerplotargs(L) layerplotargs(L) <- value } \arguments{ \item{L}{ An object of class \code{"layered"} created by the function \code{\link{layered}}. } \item{value}{ Replacement value. A list, with the same length as \code{L}, whose elements are lists of plot arguments. } } \details{ These commands extract or replace the \code{plotargs} in a layered object. See \code{\link{layered}}. The replacement \code{value} should normally have the same length as the current value. However, it can also be a list with \emph{one} element which is a list of parameters. This will be replicated to the required length. For the assignment function \code{layerplotargs<-}, the argument \code{L} can be any spatial object; it will be converted to a \code{layered} object with a single layer. } \value{ \code{layerplotargs} returns a list of lists of plot arguments. \code{"layerplotargs<-"} returns the updated object of class \code{"layered"}. } \author{\adrian and \rolf } \seealso{ \code{\link{layered}}, \code{\link{methods.layered}}, \code{\link{[.layered}}. } \examples{ W <- square(2) L <- layered(W=W, X=cells) ## The following are equivalent layerplotargs(L) <- list(list(), list(pch=16)) layerplotargs(L)[[2]] <- list(pch=16) layerplotargs(L)$X <- list(pch=16) ## The following are equivalent layerplotargs(L) <- list(list(cex=2), list(cex=2)) layerplotargs(L) <- list(list(cex=2)) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/summary.psp.Rd0000644000176200001440000000136614611065350016412 0ustar liggesusers\name{summary.psp} \alias{summary.psp} \title{Summary of a Line Segment Pattern Dataset} \description{ Prints a useful summary of a line segment pattern dataset. } \usage{ \method{summary}{psp}(object, \dots) } \arguments{ \item{object}{Line segment pattern (object of class \code{"psp"}).} \item{\dots}{Ignored.} } \details{ A useful summary of the line segment pattern \code{object} is printed. This is a method for the generic function \code{\link{summary}}. } \seealso{ \code{\link{summary}}, \code{\link{summary.owin}}, \code{\link{print.psp}} } \examples{ a <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) summary(a) # describes it } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/interp.im.Rd0000644000176200001440000000370714611065346016027 0ustar liggesusers\name{interp.im} \alias{interp.im} \title{Interpolate a Pixel Image} \description{ Interpolates the values of a pixel image at any desired location in the frame. } \usage{ interp.im(Z, x, y=NULL, bilinear=FALSE) } \arguments{ \item{Z}{ Pixel image (object of class \code{"im"}) with numeric or integer values. } \item{x,y}{ Vectors of Cartesian coordinates. Alternatively \code{x} can be a point pattern and \code{y} can be missing. } \item{bilinear}{ Logical value specifying the choice of interpolation rule. If \code{bilinear=TRUE} then a bilinear interpolation rule is used. If \code{bilinear=FALSE} (the default) then a slightly biased rule is used; this rule is consistent with earlier versions of \pkg{spatstat}. } } \details{ A value at each location \code{(x[i],y[i])} will be interpolated using the pixel values of \code{Z} at the four surrounding pixel centres, by simple bilinear interpolation. At the boundary (where \code{(x[i],y[i])} is not surrounded by four pixel centres) the value at the nearest pixel is taken. The arguments \code{x,y} can be anything acceptable to \code{\link[grDevices]{xy.coords}}. } \value{ Vector of interpolated values, with \code{NA} for points that lie outside the domain of the image. } \examples{ opa <- par(mfrow=c(1,2)) # coarse image V <- as.im(function(x,y) { x^2 + y }, owin(), dimyx=10) plot(V, main="coarse image", col=terrain.colors(256)) # lookup value at location (0.5,0.5) V[list(x=0.5,y=0.5)] # interpolated value at location (0.5,0.5) interp.im(V, 0.5, 0.5) interp.im(V, 0.5, 0.5, bilinear=TRUE) # true value is 0.75 # how to obtain an interpolated image at a desired resolution U <- as.im(interp.im, W=owin(), Z=V, dimyx=256) plot(U, main="interpolated image", col=terrain.colors(256)) par(opa) } \author{ \adrian and \rolf, with a contribution from an anonymous user. } \keyword{spatial} \keyword{manip} spatstat.geom/man/venn.tess.Rd0000644000176200001440000000412014611065351016027 0ustar liggesusers\name{venn.tess} \alias{venn.tess} \title{ Tessellation Delimited by Several Sets } \description{ Given a list of windows, construct the tessellation formed by all combinations of inclusion/exclusion of these windows. } \usage{ venn.tess(\dots, window = NULL, labels=FALSE) } \arguments{ \item{\dots}{ Sets which delimit the tessellation. Any number of windows (objects of class \code{"owin"}) or tessellations (objects of class \code{"tess"}). } \item{window}{ Optional. The bounding window of the resulting tessellation. If not specified, the default is the union of all the arguments \code{\dots}. } \item{labels}{ Logical value, specifying whether to attach marks to each tile that reveal how it was formed. } } \details{ The arguments \code{\dots} may be any number of windows. This function constructs a tessellation, like a Venn diagram, whose boundaries are made up of the boundaries of these sets. Each tile of the tessellation is defined by one of the possible combinations in which each set is either included or excluded. If the arguments \code{\dots} are named, then the resulting tiles will also have tile names, which identify the inclusion/exclusion combinations defining each tile. See the Examples. If \code{labels=TRUE} then the tiles have marks which indicate the inclusion/exclusion combinations defining each tile. See the Examples. } \value{ A tessellation (object of class \code{"tess"}). } \author{ \spatstatAuthors. } \seealso{ \code{\link{intersect.tess}}. To construct other kinds of tessellations, see \code{\link{tess}}, \code{\link{quadrats}}, \code{\link{hextess}}, \code{\link{polartess}}, \code{\link{dirichlet}}, \code{\link{delaunay}}, \code{\link{quantess}} and \code{\link[spatstat.random]{rpoislinetess}}. } \examples{ A <- square(1) B <- square(c(-0.5,0.5)) W <- square(c(-1, 1.5)) V <- venn.tess(A=A, B=B, window=W) V plot(V, do.labels=TRUE) Vlab <- venn.tess(A=A, B=B, window=W, labels=TRUE) marks(Vlab) } \keyword{spatial} \keyword{math} \concept{Tessellation} spatstat.geom/man/chop.tess.Rd0000644000176200001440000000307414611065345016024 0ustar liggesusers\name{chop.tess} \alias{chop.tess} \title{Subdivide a Window or Tessellation using a Set of Lines} \description{ Divide a given window into tiles delineated by a set of infinite straight lines, obtaining a tessellation of the window. Alternatively, given a tessellation, divide each tile of the tessellation into sub-tiles delineated by the lines. } \usage{ chop.tess(X, L) } \arguments{ \item{X}{ A window (object of class \code{"owin"}) or tessellation (object of class \code{"tess"}) to be subdivided by lines. } \item{L}{ A set of infinite straight lines (object of class \code{"infline"}) } } \details{ The argument \code{L} should be a set of infinite straight lines in the plane (stored in an object \code{L} of class \code{"infline"} created by the function \code{\link{infline}}). If \code{X} is a window, then it is divided into tiles delineated by the lines in \code{L}. If \code{X} is a tessellation, then each tile of \code{X} is subdivided into sub-tiles delineated by the lines in \code{L}. The result is a tessellation. } \section{Warning}{ If \code{X} is a non-convex window, or a tessellation containing non-convex tiles, then \code{chop.tess(X,L)} may contain a tile which consists of several unconnected pieces. } \value{ A tessellation (object of class \code{"tess"}). } \author{\adrian and \rolf } \seealso{ \code{\link{infline}}, \code{\link{clip.infline}} } \examples{ L <- infline(p=1:3, theta=pi/4) W <- square(4) chop.tess(W, L) } \keyword{spatial} \keyword{math} \concept{Tessellation} spatstat.geom/man/default.dummy.Rd0000644000176200001440000000730314611065345016673 0ustar liggesusers\name{default.dummy} \alias{default.dummy} \title{Generate a Default Pattern of Dummy Points} \description{ Generates a default pattern of dummy points for use in a quadrature scheme. } \usage{ default.dummy(X, nd, random=FALSE, ntile=NULL, npix=NULL, quasi=FALSE, \dots, eps=NULL, verbose=FALSE) } \arguments{ \item{X}{ The observed data point pattern. An object of class \code{"ppp"} or in a format recognised by \code{\link{as.ppp}()} } \item{nd}{ Optional. Integer, or integer vector of length 2, specifying an \code{nd * nd} or \code{nd[1] * nd[2]} rectangular array of dummy points. } \item{random}{ Logical value. If \code{TRUE}, the dummy points are generated randomly. } \item{quasi}{ Logical value. If \code{TRUE}, the dummy points are generated by a quasirandom sequence. } \item{ntile}{ Optional. Integer or pair of integers specifying the number of rows and columns of tiles used in the counting rule. } \item{npix}{ Optional. Integer or pair of integers specifying the number of rows and columns of pixels used in computing approximate areas. } \item{\dots}{ Ignored. } \item{eps}{ Optional. Grid spacing. A positive number, or a vector of two positive numbers, giving the horizontal and vertical spacing, respectively, of the grid of dummy points. Incompatible with \code{nd}. } \item{verbose}{ If \code{TRUE}, information about the construction of the quadrature scheme is printed. } } \value{ A point pattern (an object of class \code{"ppp"}, see \code{\link{ppp.object}}) containing the dummy points. } \details{ This function provides a sensible default for the dummy points in a quadrature scheme. A quadrature scheme consists of the original data point pattern, an additional pattern of dummy points, and a vector of quadrature weights for all these points. See \code{\link{quad.object}} for further information about quadrature schemes. If \code{random} and \code{quasi} are both false (the default), then the function creates dummy points in a regular \code{nd[1]} by \code{nd[1]} rectangular grid. If \code{random} is true and \code{quasi} is false, then the frame of the window is divided into an \code{nd[1]} by \code{nd[1]} array of tiles, and one dummy point is generated at random inside each tile. If \code{quasi} is true, a quasirandom pattern of \code{nd[1] * nd[2]} points is generated. In all cases, the four corner points of the frame of the window are added. Then if the window is not rectangular, any dummy points lying outside it are deleted. If \code{nd} is missing, a default value is computed by the undocumented internal function \code{\link{default.n.tiling}}, using information about the data pattern \code{X}, and other arguments and settings. The default value of \code{nd} is always greater than or equal to \code{spatstat.options("ndummy.min")} and greater than or equal to \code{10 * ceiling(2 * sqrt(npoints(X))/10)}, and satisfies some other constraints. The default is designed so that model-fitting is relatively fast and stable, rather than highly accurate. Alternative functions for creating dummy patterns include \code{\link{corners}}, \code{\link{gridcentres}}, \code{\link{stratrand}} and \code{\link{spokes}}. } \seealso{ \code{\link{quad.object}}, \code{\link{quadscheme}}, \code{\link{corners}}, \code{\link{gridcentres}}, \code{\link{stratrand}}, \code{\link{spokes}} } \examples{ P <- simdat D <- default.dummy(P, 100) \donttest{plot(D)} Q <- quadscheme(P, D, "grid") if(interactive()) {plot(union.quad(Q))} } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/Math.im.Rd0000644000176200001440000000711414611065344015411 0ustar liggesusers\name{Math.im} \alias{Math.im} \alias{Ops.im} \alias{Complex.im} \alias{Summary.im} \title{S3 Group Generic methods for images} \description{ These are group generic methods for images of class \code{"im"}, which allows for usual mathematical functions and operators to be applied directly to images. See Details for a list of implemented functions. } \usage{ ## S3 methods for group generics have prototypes: \special{Math(x, \dots)} \special{Ops(e1, e2)} \special{Complex(z)} \special{Summary(\dots, na.rm=FALSE, drop=TRUE)} %NAMESPACE S3method("Math", "im") %NAMESPACE S3method("Ops", "im") %NAMESPACE S3method("Complex", "im") %NAMESPACE S3method("Summary", "im") } \arguments{ \item{x, z, e1, e2}{objects of class \code{"im"}.} \item{\dots}{further arguments passed to methods.} \item{na.rm,drop}{ Logical values specifying whether missing values should be removed. This will happen if either \code{na.rm=TRUE} or \code{drop=TRUE}. See Details. } } \details{ Below is a list of mathematical functions and operators which are defined for images. Not all functions will make sense for all types of images. For example, none of the functions in the \code{"Math"} group make sense for character-valued images. Note that the \code{"Ops"} group methods are implemented using \code{\link{eval.im}}, which tries to harmonise images via \code{\link{harmonise.im}} if they aren't compatible to begin with. \enumerate{ \item Group \code{"Math"}: \itemize{ \item \code{abs}, \code{sign}, \code{sqrt},\cr \code{floor}, \code{ceiling}, \code{trunc},\cr \code{round}, \code{signif} \item \code{exp}, \code{log}, \code{expm1}, \code{log1p},\cr \code{cos}, \code{sin}, \code{tan},\cr \code{cospi}, \code{sinpi}, \code{tanpi},\cr \code{acos}, \code{asin}, \code{atan} \code{cosh}, \code{sinh}, \code{tanh},\cr \code{acosh}, \code{asinh}, \code{atanh} \item \code{lgamma}, \code{gamma}, \code{digamma}, \code{trigamma} \item \code{cumsum}, \code{cumprod}, \code{cummax}, \code{cummin} } \item Group \code{"Ops"}: \itemize{ \item \code{"+"}, \code{"-"}, \code{"*"}, \code{"/"}, \code{"^"}, \code{"\%\%"}, \code{"\%/\%"} \item \code{"&"}, \code{"|"}, \code{"!"} \item \code{"=="}, \code{"!="}, \code{"<"}, \code{"<="}, \code{">="}, \code{">"} } \item Group \code{"Summary"}: \itemize{ \item \code{all}, \code{any} \item \code{sum}, \code{prod} \item \code{min}, \code{max} \item \code{range} } \item Group \code{"Complex"}: \itemize{ \item \code{Arg}, \code{Conj}, \code{Im}, \code{Mod}, \code{Re} } } For the \code{Summary} group, the generic has an argument \code{na.rm=FALSE}, but for pixel images it makes sense to set \code{na.rm=TRUE} so that pixels outside the domain of the image are ignored. To enable this, we added the argument \code{drop}. Pixel values that are \code{NA} are removed if \code{drop=TRUE} or if \code{na.rm=TRUE}. For the \code{Ops} group, one of the arguments is permitted to be a single atomic value instead of an image. } \seealso{ \code{\link{eval.im}} for evaluating expressions involving images. } \examples{ ## Convert gradient values to angle of inclination: V <- atan(bei.extra$grad) * 180/pi ## Make logical image which is TRUE when heat equals 'Moderate': A <- (gorillas.extra$heat == "Moderate") ## Summary: any(A) ## Complex: Z <- exp(1 + V * 1i) Z Re(Z) } \author{ \spatstatAuthors and Kassel Hingee. } \keyword{spatial} \keyword{methods} spatstat.geom/man/Extract.im.Rd0000644000176200001440000002000714611065346016130 0ustar liggesusers\name{Extract.im} \alias{[.im} \title{Extract Subset of Image} \description{ Extract a subset or subregion of a pixel image. } \usage{ \method{[}{im}(x, i, j, \dots, drop=TRUE, tight=FALSE, raster=NULL, rescue=is.owin(i)) } \arguments{ \item{x}{ A two-dimensional pixel image. An object of class \code{"im"}. } \item{i}{ Object defining the subregion or subset to be extracted. Either a spatial window (an object of class \code{"owin"}), or a pixel image with logical values, or a linear network (object of class \code{"linnet"}) or a point pattern (an object of class \code{"ppp"}), or any type of index that applies to a matrix, or something that can be converted to a point pattern by \code{\link{as.ppp}} (using the window of \code{x}). } \item{j}{ An integer or logical vector serving as the column index if matrix indexing is being used. Ignored if \code{i} is a spatial object. } \item{\dots}{Ignored.} \item{drop}{ Logical value, specifying whether to return a vector containing the selected pixel values (\code{drop=TRUE}, the default) or to return a pixel image containing these values in their original spatial positions (\code{drop=FALSE}). The exception is that if \code{i} is a point pattern, then \code{drop} specifies whether to delete \code{NA} values. See Details. } \item{tight}{ Logical value. If \code{tight=TRUE}, and if the result of the subset operation is an image, the image will be trimmed to the smallest possible rectangle. } \item{raster}{ Optional. An object of class \code{"owin"} or \code{"im"} determining a pixel grid. } \item{rescue}{ Logical value indicating whether rectangular blocks of data should always be returned as pixel images. } } \value{ Either a pixel image or a vector of pixel values. See Details. } \details{ This function extracts a subset of the pixel values in a pixel image. (To reassign the pixel values, see \code{\link{[<-.im}}). The image \code{x} must be an object of class \code{"im"} representing a pixel image defined inside a rectangle in two-dimensional space (see \code{\link{im.object}}). The subset to be extracted is determined by the arguments \code{i,j} according to the following rules (which are checked in this order): \enumerate{ \item \code{i} is a spatial object such as a window, a pixel image with logical values, a linear network, or a point pattern; or \item \code{i,j} are indices for the matrix \code{as.matrix(x)}; or \item \code{i} can be converted to a point pattern by \code{\link{as.ppp}(i, W=Window(x))}, and \code{i} is not a matrix. } If \code{i} is a spatial window (an object of class \code{"owin"}), the pixels inside this window are selected. \itemize{ \item If \code{drop=TRUE} (the default) and either \code{is.rectangle(i)=FALSE} or \code{rescue=FALSE}, the pixel values are extracted; the result is a vector, with one entry for each pixel of \code{x} that lies inside the window \code{i}. Pixel values may be \code{NA}, indicating that the selected pixel lies outside the spatial domain of the image. \item if \code{drop=FALSE}, the result is another pixel image, obtained by setting the pixel values to \code{NA} outside the window \code{i}. The effect is that the pixel image \code{x} is clipped to the window \code{i}. \item if \code{i} is a rectangle and \code{rescue=TRUE}, the result is a pixel image as described above. \item To ensure that an image is produced in all circumstances, set \code{drop=FALSE}. To ensure that pixel values are extracted as a vector in all circumstances, set \code{drop=TRUE, rescue=FALSE}. } If \code{i} is a pixel image with logical values, it is interpreted as a spatial window (with \code{TRUE} values inside the window and \code{FALSE} outside). If \code{i} is a linear network (object of class \code{"linnet"}), the pixels which lie on this network are selected. \itemize{ \item If \code{drop=TRUE} (the default), the pixel values are extracted; the result is a vector, with one entry for each pixel of \code{x} that lies along the network \code{i}. Pixel values may be \code{NA}, indicating that the selected pixel lies outside the spatial domain of the image. \item if \code{drop=FALSE}, the result is a pixel image on a linear network (object of class \code{"linim"}), obtained by setting the pixel values of \code{x} to \code{NA} except for those which lie on the network \code{i}. The effect is that the pixel image \code{x} is restricted to the network \code{i}. } If \code{i} is a point pattern (an object of class \code{"ppp"}) or something that can be converted to a point pattern, then the values of the pixel image at the points of this pattern are extracted. The result is a vector of pixel values. This is a simple way to read the pixel values at a given spatial location. \itemize{ \item if \code{drop=FALSE} the length of the result is equal to the number of points in the pattern. It may contain \code{NA} values which indicate that the corresponding point lies outside the spatial domain of the image. \item if \code{drop=TRUE} (the default), \code{NA} values are deleted. The result is a vector whose length may be shorter than the number of points of the pattern. } If the optional argument \code{raster} is given, then it should be a binary image mask or a pixel image. Then \code{x} will first be converted to an image defined on the pixel grid implied by \code{raster}, before the subset operation is carried out. In particular, \code{x[i, raster=i, drop=FALSE]} will return an image defined on the same pixel array as the object \code{i}. If \code{i} does not satisfy any of the conditions above, then the algorithm attempts to interpret \code{i} and \code{j} as indices for the matrix \code{as.matrix(x)}. Either \code{i} or \code{j} may be missing or blank. The result is usually a vector or matrix of pixel values. Exceptionally the result is a pixel image if \code{i,j} determines a rectangular subset of the pixel grid, and if the user specifies \code{rescue=TRUE}. Finally, if none of the above conditions is met, the object \code{i} may also be a data frame or list of \code{x,y} coordinates which will be converted to a point pattern, taking the observation window to be \code{Window(x)}. Then the pixel values at these points will be extracted as a vector. } \section{Warnings}{ If you have a 2-column matrix containing the \eqn{x,y} coordinates of point locations, then to prevent this being interpreted as an array index, you should convert it to a \code{data.frame} or to a point pattern. If \code{W} is a window or a pixel image, then \code{x[W, drop=FALSE]} will return an image defined on the same pixel array as the original image \code{x}. If you want to obtain an image whose pixel dimensions agree with those of \code{W}, use the \code{raster} argument, \code{x[W, raster=W, drop=FALSE]}. } \seealso{ \code{\link{im.object}}, \code{\link{[<-.im}}, \code{\link{ppp.object}}, \code{\link{as.ppp}}, \code{\link{owin.object}}, \code{\link{plot.im}} } \examples{ # make up an image X <- setcov(unit.square()) plot(X) # a rectangular subset W <- owin(c(0,0.5),c(0.2,0.8)) Y <- X[W] plot(Y) # a polygonal subset R <- affine(letterR, diag(c(1,1)/2), c(-2,-0.7)) plot(X[R, drop=FALSE]) plot(X[R, drop=FALSE, tight=TRUE]) # a point pattern Y <- X[cells] # look up a specified location X[list(x=0.1,y=0.2)] # 10 x 10 pixel array X <- as.im(function(x,y) { x + y }, owin(c(-1,1),c(-1,1)), dimyx=10) # 100 x 100 W <- as.mask(disc(1, c(0,0)), dimyx=100) # 10 x 10 raster X[W,drop=FALSE] # 100 x 100 raster X[W, raster=W, drop=FALSE] } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/dirichlet.Rd0000644000176200001440000000334114611065346016063 0ustar liggesusers\name{dirichlet} \alias{dirichlet} \title{Dirichlet Tessellation of Point Pattern} \description{ Computes the Dirichlet tessellation of a spatial point pattern. Also known as the Voronoi or Thiessen tessellation. } \usage{ dirichlet(X) } \arguments{ \item{X}{Spatial point pattern (object of class \code{"ppp"}).} } \details{ In a spatial point pattern \code{X}, the Dirichlet tile associated with a particular point \code{X[i]} is the region of space that is closer to \code{X[i]} than to any other point in \code{X}. The Dirichlet tiles divide the two-dimensional plane into disjoint regions, forming a tessellation. The Dirichlet tessellation is also known as the Voronoi or Thiessen tessellation. This function computes the Dirichlet tessellation (within the original window of \code{X}) using the function \code{\link[deldir]{deldir}} in the package \pkg{deldir}. To ensure that there is a one-to-one correspondence between the points of \code{X} and the tiles of \code{dirichlet(X)}, duplicated points in \code{X} should first be removed by \code{X <- unique(X, rule="deldir")}. The tiles of the tessellation will be computed as polygons if the original window is a rectangle or a polygon. Otherwise the tiles will be computed as binary masks. } \value{ A tessellation (object of class \code{"tess"}). } \seealso{ \code{\link{tess}}, \code{\link{delaunay}}, \code{\link{ppp}}, \code{\link{dirichletVertices}}. For the Dirichlet tessellation on a linear network, see \code{\link[spatstat.linnet]{lineardirichlet}}. } \examples{ X <- runifrect(42) plot(dirichlet(X)) plot(X, add=TRUE) } \author{ \adrian and \rolf. } \keyword{spatial} \keyword{manip} \concept{Dirichlet tessellation} spatstat.geom/man/tileindex.Rd0000644000176200001440000000275614611065351016106 0ustar liggesusers\name{tileindex} \alias{tileindex} \title{ Determine Which Tile Contains Each Given Point } \description{ Given a tessellation and a list of spatial points, determine which tile of the tessellation contains each of the given points. } \usage{ tileindex(x, y, Z) } \arguments{ \item{x,y}{ Spatial coordinates. Numeric vectors of equal length. (Alternatively \code{y} may be missing and \code{x} may be an object containing spatial coordinates). } \item{Z}{ A tessellation (object of class \code{"tess"}). } } \details{ This function determines which tile of the tessellation \code{Z} contains each of the spatial points with coordinates \code{(x[i],y[i])}. The result is a factor, of the same length as \code{x} and \code{y}, indicating which tile contains each point. The levels of the factor are the names of the tiles of \code{Z}. Values are \code{NA} if the corresponding point lies outside the tessellation. } \value{ A factor, of the same length as \code{x} and \code{y}, whose levels are the names of the tiles of \code{Z}. } \author{ \spatstatAuthors } \seealso{ \code{\link{cut.ppp}} and \code{\link{split.ppp}} to divide up the points of a point pattern according to a tessellation. \code{\link{as.function.tess}} to create a function whose value is the tile index. } \examples{ X <- runifrect(7) V <- dirichlet(X) tileindex(0.1, 0.4, V) tileindex(list(x=0.1, y=0.4), Z=V) tileindex(X, Z=V) } \keyword{spatial} \keyword{manip} spatstat.geom/man/split.hyperframe.Rd0000644000176200001440000000365614611065350017414 0ustar liggesusers\name{split.hyperframe} \alias{split.hyperframe} \alias{split<-.hyperframe} \title{ Divide Hyperframe Into Subsets and Reassemble } \description{ \code{split} divides the data \code{x} into subsets defined by \code{f}. The replacement form replaces values corresponding to such a division. } \usage{ \method{split}{hyperframe}(x, f, drop = FALSE, ...) \method{split}{hyperframe}(x, f, drop = FALSE, ...) <- value } \arguments{ \item{x}{ Hyperframe (object of class \code{"hyperframe"}). } \item{f}{ a \code{factor} in the sense that \code{as.factor(f)} defines the grouping, or a list of such factors in which case their interaction is used for the grouping. } \item{drop}{ logical value, indicating whether levels that do not occur should be dropped from the result. } \item{value}{ a list of hyperframes which arose (or could have arisen) from the command \code{split(x,f,drop=drop)}. } \item{\dots}{ Ignored. } } \details{ These are methods for the generic functions \code{\link{split}} and \code{\link{split<-}} for hyperframes (objects of class \code{"hyperframe"}). A hyperframe is like a data frame, except that its entries can be objects of any kind. The behaviour of these methods is analogous to the corresponding methods for data frames. } \value{ The value returned from \code{split.hyperframe} is a list of hyperframe containing the values for the groups. The components of the list are named by the levels of \code{f} (after converting to a factor, or if already a factor and \code{drop = TRUE}, dropping unused levels). The replacement method \code{split<-.hyperframe} returns a new hyperframe \code{x} for which \code{split(x,f)} equals \code{value}. } \author{\adrian , \rolf and \ege } \seealso{ \code{\link{hyperframe}}, \code{\link{[.hyperframe}} } \examples{ split(pyramidal, pyramidal$group) } \keyword{spatial} \keyword{manip} spatstat.geom/man/rounding.ppp.Rd0000644000176200001440000000377314632242004016537 0ustar liggesusers\name{rounding.ppp} \alias{rounding.ppp} \alias{rounding.pp3} \alias{rounding.ppx} \title{ Detect Numerical Rounding } \description{ Given a numeric vector, or an object containing numeric spatial coordinates, determine whether the values have been rounded to a certain number of decimal places. } \usage{ \method{rounding}{ppp}(x) \method{rounding}{pp3}(x) \method{rounding}{ppx}(x) } \arguments{ \item{x}{ A point pattern (object of class \code{ppp}, \code{pp3} or \code{ppx}). } } \details{ The functions documented here are methods for the generic \code{\link[spatstat.univar]{rounding}}. They determine whether the coordinates of a spatial object have been rounded to a certain number of decimal places. \itemize{ \item If the coordinates of the points in \code{x} are not all integers, then \code{rounding(x)} returns the smallest number of digits \code{d} after the decimal point such that \code{\link[base]{round}(coords(x), digits=d)} is identical to \code{coords(x)}. For example if \code{rounding(x) = 2} then the coordinates of the points in \code{x} appear to have been rounded to 2 decimal places, and are multiples of 0.01. \item If all the coordinates of the points in \code{x} are integers, then \code{rounding(x)} returns \code{-d}, where \code{d} is the smallest number of digits \emph{before} the decimal point such that \code{\link[base]{round}(coords(x), digits=-d)} is identical to \code{coords(x)}. For example if \code{rounding(x) = -3} then the coordinates of all points in \code{x} are multiples of 1000. If \code{rounding(x) = 0} then the entries of \code{x} are integers but not multiples of 10. \item If all coordinates of points in \code{x} are equal to 0, a value of 0 is returned. } } \value{ An integer. } \author{ \adrian and \rolf } \seealso{ \code{\link{round.ppp}}, \code{\link[spatstat.univar]{rounding}} } \examples{ rounding(cells) } \keyword{spatial} \keyword{math} spatstat.geom/man/edges2triangles.Rd0000644000176200001440000000332114611065346017174 0ustar liggesusers\name{edges2triangles} \alias{edges2triangles} \title{ List Triangles in a Graph } \description{ Given a list of edges between vertices, compile a list of all triangles formed by these edges. } \usage{ edges2triangles(iedge, jedge, nvert=max(iedge, jedge), \dots, check=TRUE, friendly=rep(TRUE, nvert)) } \arguments{ \item{iedge,jedge}{ Integer vectors, of equal length, specifying the edges. } \item{nvert}{ Number of vertices in the network. } \item{\dots}{Ignored} \item{check}{Logical. Whether to check validity of input data.} \item{friendly}{ Optional. For advanced use. See Details. } } \details{ This low level function finds all the triangles (cliques of size 3) in a finite graph with \code{nvert} vertices and with edges specified by \code{iedge, jedge}. The interpretation of \code{iedge, jedge} is that each successive pair of entries specifies an edge in the graph. The \eqn{k}th edge joins vertex \code{iedge[k]} to vertex \code{jedge[k]}. Entries of \code{iedge} and \code{jedge} must be integers from 1 to \code{nvert}. To improve efficiency in some applications, the optional argument \code{friendly} can be used. It should be a logical vector of length \code{nvert} specifying a labelling of the vertices, such that two vertices \code{j,k} which are \emph{not} friendly (\code{friendly[j] = friendly[k] = FALSE}) are \emph{never} connected by an edge. } \value{ A 3-column matrix of integers, in which each row represents a triangle. } \seealso{ \code{\link{edges2vees}} } \author{\adrian and \rolf } \examples{ i <- c(1, 2, 5, 5, 1, 4, 2) j <- c(2, 3, 3, 1, 3, 2, 5) edges2triangles(i, j) } \keyword{spatial} \keyword{manip} spatstat.geom/man/nnwhich.ppx.Rd0000644000176200001440000000541714611065347016367 0ustar liggesusers\name{nnwhich.ppx} \alias{nnwhich.ppx} \title{Nearest Neighbours in Any Dimensions} \description{ Finds the nearest neighbour of each point in a multi-dimensional point pattern. } \usage{ \method{nnwhich}{ppx}(X, \dots, k=1) } \arguments{ \item{X}{ Multi-dimensional point pattern (object of class \code{"ppx"}). } \item{\dots}{ Arguments passed to \code{\link{coords.ppx}} to determine which coordinates should be used. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } } \value{ Numeric vector or matrix giving, for each point, the index of its nearest neighbour (or \code{k}th nearest neighbour). If \code{k = 1} (the default), the return value is a numeric vector \code{v} giving the indices of the nearest neighbours (the nearest neighbout of the \code{i}th point is the \code{j}th point where \code{j = v[i]}). If \code{k} is a single integer, then the return value is a numeric vector giving the indices of the \code{k}th nearest neighbours. If \code{k} is a vector, then the return value is a matrix \code{m} such that \code{m[i,j]} is the index of the \code{k[j]}th nearest neighbour for the \code{i}th data point. } \details{ For each point in the given multi-dimensional point pattern, this function finds its nearest neighbour (the nearest other point of the pattern). By default it returns a vector giving, for each point, the index of the point's nearest neighbour. If \code{k} is specified, the algorithm finds each point's \code{k}th nearest neighbour. The function \code{nnwhich} is generic. This is the method for the class \code{"ppx"}. If there are no points in the pattern, a numeric vector of length zero is returned. If there is only one point, then the nearest neighbour is undefined, and a value of \code{NA} is returned. In general if the number of points is less than or equal to \code{k}, then a vector of \code{NA}'s is returned. To evaluate the \emph{distance} between a point and its nearest neighbour, use \code{\link{nndist}}. To find the nearest neighbours from one point pattern to another point pattern, use \code{\link{nncross}}. By default, both spatial and temporal coordinates are extracted. To obtain the spatial distance between points in a space-time point pattern, set \code{temporal=FALSE}. } \section{Warnings}{ A value of \code{NA} is returned if there is only one point in the point pattern. } \seealso{ \code{\link{nnwhich}}, \code{\link{nndist}}, \code{\link{nncross}} } \examples{ df <- data.frame(x=runif(5),y=runif(5),z=runif(5),w=runif(5)) X <- ppx(data=df) m <- nnwhich(X) m2 <- nnwhich(X, k=2) } \author{ \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/is.multitype.Rd0000644000176200001440000000327714611065346016572 0ustar liggesusers\name{is.multitype} \alias{is.multitype} \title{Test whether Object is Multitype} \description{ Generic function to test whether a given object (usually a point pattern or something related to a point pattern) has ``marks'' attached to the points which classify the points into several types. } \usage{ is.multitype(X, \dots) } \arguments{ \item{X}{ Object to be inspected } \item{\dots}{ Other arguments. } } \value{ Logical value, equal to \code{TRUE} if \code{X} is multitype. } \details{ ``Marks'' are observations attached to each point of a point pattern. For example the \code{\link[spatstat.data]{longleaf}} dataset contains the locations of trees, each tree being marked by its diameter; the \code{\link[spatstat.data]{amacrine}} dataset gives the locations of cells of two types (on/off) and the type of cell may be regarded as a mark attached to the location of the cell. Other objects related to point patterns, such as point process models, may involve marked points. This function tests whether the object \code{X} contains or involves marked points, \bold{and} that the marks are a factor. For example, the \code{\link[spatstat.data]{amacrine}} dataset is multitype (there are two types of cells, on and off), but the \code{\link[spatstat.data]{longleaf}} dataset is \emph{not} multitype (the marks are real numbers). This function is generic; methods are provided for point patterns (objects of class \code{"ppp"}) and point process models (objects of class \code{"ppm"}). } \seealso{ \code{\link{is.multitype.ppp}}, \code{\link[spatstat.model]{is.multitype.ppm}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/Extract.anylist.Rd0000644000176200001440000000226614611065346017215 0ustar liggesusers\name{Extract.anylist} \alias{[.anylist} \alias{[<-.anylist} \title{Extract or Replace Subset of a List of Things} \description{ Extract or replace a subset of a list of things. } \usage{ \method{[}{anylist}(x, i, \dots) \method{[}{anylist}(x, i) <- value } \arguments{ \item{x}{ An object of class \code{"anylist"} representing a list of things. } \item{i}{ Subset index. Any valid subset index in the usual \R sense. } \item{value}{ Replacement value for the subset. } \item{\dots}{Ignored.} } \value{ Another object of class \code{"anylist"}. } \details{ These are the methods for extracting and replacing subsets for the class \code{"anylist"}. The argument \code{x} should be an object of class \code{"anylist"} representing a list of things. See \code{\link{anylist}}. The method replaces a designated subset of \code{x}, and returns an object of class \code{"anylist"}. } \seealso{ \code{\link{anylist}}, \code{\link{plot.anylist}}, \code{\link{summary.anylist}} } \examples{ x <- anylist(A=runif(10), B=runif(10), C=runif(10)) x[1] <- list(A=rnorm(10)) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{list} \keyword{manip} spatstat.geom/man/nncross.ppx.Rd0000644000176200001440000001026614611065347016414 0ustar liggesusers\name{nncross.ppx} \alias{nncross.ppx} \title{Nearest Neighbours Between Two Patterns in Any Dimensions} \description{ Given two point patterns \code{X} and \code{Y} in many dimensional space, finds the nearest neighbour in \code{Y} of each point of \code{X}. } \usage{ \method{nncross}{ppx}(X, Y, iX=NULL, iY=NULL, what = c("dist", "which"), \dots, k = 1) } \arguments{ \item{X,Y}{ Point patterns in any number of spatial dimensions (objects of class \code{"ppx"}). } \item{iX, iY}{Optional identifiers, used to determine whether a point in \code{X} is identical to a point in \code{Y}. See Details. } \item{what}{ Character string specifying what information should be returned. Either the nearest neighbour distance (\code{"dist"}), the identifier of the nearest neighbour (\code{"which"}), or both. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } \item{\dots}{Ignored.} } \details{ Given two point patterns \code{X} and \code{Y} in \eqn{m}-dimensional space, this function finds, for each point of \code{X}, the nearest point of \code{Y}. The distance between these points is also computed. If the argument \code{k} is specified, then the \code{k}-th nearest neighbours will be found. The return value is a data frame, with rows corresponding to the points of \code{X}. The first column gives the nearest neighbour distances (i.e. the \code{i}th entry is the distance from the \code{i}th point of \code{X} to the nearest element of \code{Y}). The second column gives the indices of the nearest neighbours (i.e.\ the \code{i}th entry is the index of the nearest element in \code{Y}.) If \code{what="dist"} then only the vector of distances is returned. If \code{what="which"} then only the vector of indices is returned. The argument \code{k} may be an integer or an integer vector. If it is a single integer, then the \code{k}-th nearest neighbours are computed. If it is a vector, then the \code{k[i]}-th nearest neighbours are computed for each entry \code{k[i]}. For example, setting \code{k=1:3} will compute the nearest, second-nearest and third-nearest neighbours. The result is a data frame. Note that this function is not symmetric in \code{X} and \code{Y}. To find the nearest neighbour in \code{X} of each point in \code{Y}, use \code{nncross(Y,X)}. The arguments \code{iX} and \code{iY} are used when the two point patterns \code{X} and \code{Y} have some points in common. In this situation \code{nncross(X, Y)} would return some zero distances. To avoid this, attach a unique integer identifier to each point, such that two points are identical if their identifying numbers are equal. Let \code{iX} be the vector of identifier values for the points in \code{X}, and \code{iY} the vector of identifiers for points in \code{Y}. Then the code will only compare two points if they have different values of the identifier. See the Examples. } \value{ A data frame, or a vector if the data frame would contain only one column. By default (if \code{what=c("dist", "which")} and \code{k=1}) a data frame with two columns: \item{dist}{Nearest neighbour distance} \item{which}{Nearest neighbour index in \code{Y}} If \code{what="dist"} and \code{k=1}, a vector of nearest neighbour distances. If \code{what="which"} and \code{k=1}, a vector of nearest neighbour indices. If \code{k} is specified, the result is a data frame with columns containing the \code{k}-th nearest neighbour distances and/or nearest neighbour indices. } \seealso{ \code{\link{nndist}} for nearest neighbour distances in a single point pattern. } \examples{ XYZ <- ppx(matrix(runif(80), 20, 4), boxx(c(0,1), c(0,1), c(0,1), c(0,1))) ## two different point patterns X <- XYZ[1:5] Y <- XYZ[10:20] nncross(X,Y) N23 <- nncross(X,Y, k=2:3) ## two patterns with some points in common X <- XYZ[1:15] Y <- XYZ[10:20] iX <- 1:15 iY <- 10:20 N <- nncross(X,Y, iX, iY, what="which") N4 <- nncross(X,Y, iX, iY, k=4) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/affine.tess.Rd0000644000176200001440000000566314611065345016331 0ustar liggesusers\name{affine.tess} \alias{reflect.tess} \alias{flipxy.tess} \alias{shift.tess} \alias{rotate.tess} \alias{scalardilate.tess} \alias{affine.tess} \title{Apply Geometrical Transformation To Tessellation} \description{ Apply various geometrical transformations of the plane to each tile in a tessellation. } \usage{ \method{reflect}{tess}(X) \method{flipxy}{tess}(X) \method{shift}{tess}(X, \dots) \method{rotate}{tess}(X, angle=pi/2, \dots, centre=NULL) \method{scalardilate}{tess}(X, f, \dots) \method{affine}{tess}(X, mat=diag(c(1,1)), vec=c(0,0), \dots) } \arguments{ \item{X}{Tessellation (object of class \code{"tess"}).} \item{angle}{ Rotation angle in radians (positive values represent anticlockwise rotations). } \item{mat}{Matrix representing a linear transformation.} \item{vec}{Vector of length 2 representing a translation.} \item{f}{Positive number giving scale factor.} \item{\dots}{Arguments passed to other methods.} \item{centre}{ Centre of rotation. Either a vector of length 2, or a character string (partially matched to \code{"centroid"}, \code{"midpoint"} or \code{"bottomleft"}). The default is the coordinate origin \code{c(0,0)}. } } \value{ Another tessellation (of class \code{"tess"}) representing the result of applying the geometrical transformation. } \details{ These are method for the generic functions \code{\link{reflect}}, \code{\link{flipxy}}, \code{\link{shift}}, \code{\link{rotate}}, \code{\link{scalardilate}}, \code{\link{affine}} for tessellations (objects of class \code{"tess"}). The individual tiles of the tessellation, and the window containing the tessellation, are all subjected to the same geometrical transformation. The transformations are performed by the corresponding method for windows (class \code{"owin"}) or images (class \code{"im"}) depending on the type of tessellation. If the argument \code{origin} is used in \code{shift.tess} it is interpreted as applying to the window containing the tessellation. Then all tiles are shifted by the same vector. } \seealso{ Generic functions \code{\link{reflect}}, \code{\link{shift}}, \code{\link{rotate}}, \code{\link{scalardilate}}, \code{\link{affine}}. Methods for windows: \code{\link{reflect.default}}, \code{\link{shift.owin}}, \code{\link{rotate.owin}}, \code{\link{scalardilate.owin}}, \code{\link{affine.owin}}. Methods for images: \code{\link{reflect.im}}, \code{\link{shift.im}}, \code{\link{rotate.im}}, \code{\link{scalardilate.im}}, \code{\link{affine.im}}. } \examples{ live <- interactive() if(live) { H <- hextess(letterR, 0.2) plot(H) plot(reflect(H)) plot(rotate(H, pi/3)) } else H <- hextess(letterR, 0.6) # shear transformation shear <- matrix(c(1,0,0.6,1),2,2) sH <- affine(H, shear) if(live) plot(sH) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} \concept{Geometrical transformations} spatstat.geom/man/nncross.Rd0000644000176200001440000001640114611065347015603 0ustar liggesusers\name{nncross} \alias{nncross} \alias{nncross.ppp} \alias{nncross.default} \title{Nearest Neighbours Between Two Patterns} \description{ Given two point patterns \code{X} and \code{Y}, finds the nearest neighbour in \code{Y} of each point of \code{X}. Alternatively \code{Y} may be a line segment pattern. } \usage{ nncross(X, Y, \dots) \method{nncross}{ppp}(X, Y, iX=NULL, iY=NULL, what = c("dist", "which"), \dots, k = 1, sortby=c("range", "var", "x", "y"), is.sorted.X = FALSE, is.sorted.Y = FALSE, metric=NULL) \method{nncross}{default}(X, Y, \dots) } \arguments{ \item{X}{Point pattern (object of class \code{"ppp"}).} \item{Y}{Either a point pattern (object of class \code{"ppp"}) or a line segment pattern (object of class \code{"psp"}).} \item{iX, iY}{Optional identifiers, applicable only in the case where \code{Y} is a point pattern, used to determine whether a point in \code{X} is identical to a point in \code{Y}. See Details. } \item{what}{ Character string specifying what information should be returned. Either the nearest neighbour distance (\code{"dist"}), the identifier of the nearest neighbour (\code{"which"}), or both. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } \item{sortby}{ Determines which coordinate to use to sort the point patterns. See Details. } \item{is.sorted.X, is.sorted.Y}{ Logical values attesting whether the point patterns \code{X} and \code{Y} have been sorted. See Details. } \item{metric}{ Optional. A distance metric (object of class \code{"metric"}, see \code{\link{metric.object}}) which will be used to compute the distances. } \item{\dots}{Ignored.} } \details{ Given two point patterns \code{X} and \code{Y} this function finds, for each point of \code{X}, the nearest point of \code{Y}. The distance between these points is also computed. If the argument \code{k} is specified, then the \code{k}-th nearest neighbours will be found. Alternatively if \code{X} is a point pattern and \code{Y} is a line segment pattern, the function finds the nearest line segment to each point of \code{X}, and computes the distance. The return value is a data frame, with rows corresponding to the points of \code{X}. The first column gives the nearest neighbour distances (i.e. the \code{i}th entry is the distance from the \code{i}th point of \code{X} to the nearest element of \code{Y}). The second column gives the indices of the nearest neighbours (i.e.\ the \code{i}th entry is the index of the nearest element in \code{Y}.) If \code{what="dist"} then only the vector of distances is returned. If \code{what="which"} then only the vector of indices is returned. The argument \code{k} may be an integer or an integer vector. If it is a single integer, then the \code{k}-th nearest neighbours are computed. If it is a vector, then the \code{k[i]}-th nearest neighbours are computed for each entry \code{k[i]}. For example, setting \code{k=1:3} will compute the nearest, second-nearest and third-nearest neighbours. The result is a data frame. Note that this function is not symmetric in \code{X} and \code{Y}. To find the nearest neighbour in \code{X} of each point in \code{Y}, where \code{Y} is a point pattern, use \code{nncross(Y,X)}. The arguments \code{iX} and \code{iY} are used when the two point patterns \code{X} and \code{Y} have some points in common. In this situation \code{nncross(X, Y)} would return some zero distances. To avoid this, attach a unique integer identifier to each point, such that two points are identical if their identifying numbers are equal. Let \code{iX} be the vector of identifier values for the points in \code{X}, and \code{iY} the vector of identifiers for points in \code{Y}. Then the code will only compare two points if they have different values of the identifier. See the Examples. } \section{Efficiency, sorting data, and pre-sorted data}{ Read this section if you care about the speed of computation. For efficiency, the algorithm sorts the point patterns \code{X} and \code{Y} into increasing order of the \eqn{x} coordinate or increasing order of the the \eqn{y} coordinate. Sorting is only an intermediate step; it does not affect the output, which is always given in the same order as the original data. By default (if \code{sortby="range"}), the sorting will occur on the coordinate that has the larger range of values (according to the frame of the enclosing window of \code{Y}). If \code{sortby = "var"}), sorting will occur on the coordinate that has the greater variance (in the pattern \code{Y}). Setting \code{sortby="x"} or \code{sortby = "y"} will specify that sorting should occur on the \eqn{x} or \eqn{y} coordinate, respectively. If the point pattern \code{X} is already sorted, then the corresponding argument \code{is.sorted.X} should be set to \code{TRUE}, and \code{sortby} should be set equal to \code{"x"} or \code{"y"} to indicate which coordinate is sorted. Similarly if \code{Y} is already sorted, then \code{is.sorted.Y} should be set to \code{TRUE}, and \code{sortby} should be set equal to \code{"x"} or \code{"y"} to indicate which coordinate is sorted. If both \code{X} and \code{Y} are sorted \emph{on the same coordinate axis} then both \code{is.sorted.X} and \code{is.sorted.Y} should be set to \code{TRUE}, and \code{sortby} should be set equal to \code{"x"} or \code{"y"} to indicate which coordinate is sorted. } \value{ A data frame, or a vector if the data frame would contain only one column. By default (if \code{what=c("dist", "which")} and \code{k=1}) a data frame with two columns: \item{dist}{Nearest neighbour distance} \item{which}{Nearest neighbour index in \code{Y}} If \code{what="dist"} and \code{k=1}, a vector of nearest neighbour distances. If \code{what="which"} and \code{k=1}, a vector of nearest neighbour indices. If \code{k} is specified, the result is a data frame with columns containing the \code{k}-th nearest neighbour distances and/or nearest neighbour indices. } \seealso{ \code{\link{nndist}} for nearest neighbour distances in a single point pattern. } \examples{ # two different point patterns X <- runifrect(15) Y <- runifrect(20) N <- nncross(X,Y)$which # note that length(N) = 15 plot(superimpose(X=X,Y=Y), main="nncross", cols=c("red","blue")) arrows(X$x, X$y, Y[N]$x, Y[N]$y, length=0.15) # third-nearest neighbour NXY <- nncross(X, Y, k=3) NXY[1:3,] # second and third nearest neighbours NXY <- nncross(X, Y, k=2:3) NXY[1:3,] # two patterns with some points in common Z <- runifrect(50) X <- Z[1:30] Y <- Z[20:50] iX <- 1:30 iY <- 20:50 N <- nncross(X,Y, iX, iY)$which N <- nncross(X,Y, iX, iY, what="which") #faster plot(superimpose(X=X, Y=Y), main="nncross", cols=c("red","blue")) arrows(X$x, X$y, Y[N]$x, Y[N]$y, length=0.15) # point pattern and line segment pattern X <- runifrect(15) Y <- psp(runif(10), runif(10), runif(10), runif(10), square(1)) N <- nncross(X,Y) } \author{ \adrian, \rolf, and Jens Oehlschlaegel } \keyword{spatial} \keyword{math} spatstat.geom/man/with.hyperframe.Rd0000644000176200001440000000517114611065351017227 0ustar liggesusers\name{with.hyperframe} \alias{with.hyperframe} \title{Evaluate an Expression in Each Row of a Hyperframe} \description{ An expression, involving the names of columns in a hyperframe, is evaluated separately for each row of the hyperframe. } \usage{ \method{with}{hyperframe}(data, expr, ..., simplify = TRUE, ee = NULL, enclos=NULL) } \arguments{ \item{data}{A hyperframe (object of class \code{"hyperframe"}) containing data. } \item{expr}{An \R language expression to be evaluated.} \item{\dots}{Ignored.} \item{simplify}{ Logical. If \code{TRUE}, the return value will be simplified to a vector whenever possible. } \item{ee}{ Alternative form of \code{expr}, as an object of class \code{"expression"}. } \item{enclos}{ An environment in which to search for objects that are not found in the hyperframe. Defaults to \code{\link{parent.frame}()}. } } \details{ This function evaluates the expression \code{expr} in each row of the hyperframe \code{data}. It is a method for the generic function \code{\link{with}}. The argument \code{expr} should be an \R language expression in which each variable name is either the name of a column in the hyperframe \code{data}, or the name of an object in the parent frame (the environment in which \code{with} was called.) The argument \code{ee} can be used as an alternative to \code{expr} and should be an expression object (of class \code{"expression"}). For each row of \code{data}, the expression will be evaluated so that variables which are column names of \code{data} are interpreted as the entries for those columns in the current row. For example, if a hyperframe \code{h} has columns called \code{A} and \code{B}, then \code{with(h, A != B)} inspects each row of \code{data} in turn, tests whether the entries in columns \code{A} and \code{B} are equal, and returns the \eqn{n} logical values. } \value{ Normally a list of length \eqn{n} (where \eqn{n} is the number of rows) containing the results of evaluating the expression for each row. If \code{simplify=TRUE} and each result is a single atomic value, then the result is a vector or factor containing the same values. } \author{\adrian and \rolf } \seealso{ \code{\link{hyperframe}}, \code{\link{plot.hyperframe}} } \examples{ # generate Poisson point patterns with intensities 10 to 100 H <- hyperframe(L=seq(10,100, by=10)) if(require(spatstat.random)) { X <- with(H, rpoispp(L)) } else { X <- with(H, runifrect(rpois(1, L))) } } \keyword{spatial} \keyword{manip} \keyword{programming} spatstat.geom/man/cut.ppp.Rd0000644000176200001440000001105114611065345015501 0ustar liggesusers\name{cut.ppp} \alias{cut.ppp} \title{Classify Points in a Point Pattern} \description{ Classifies the points in a point pattern into distinct types according to the numerical marks in the pattern, or according to another variable. } \usage{ \method{cut}{ppp}(x, z=marks(x), ...) } \arguments{ \item{x}{ A two-dimensional point pattern. An object of class \code{"ppp"}. } \item{z}{ Data determining the classification. A numeric vector, a factor, a pixel image, a window, a tessellation, or a string giving the name of a column of marks or the name of a spatial coordinate. } \item{\dots}{ Arguments passed to \code{\link{cut.default}}. They determine the breakpoints for the mapping from numerical values in \code{z} to factor values in the output. See \code{\link{cut.default}}. } } \value{ A multitype point pattern, that is, a point pattern object (of class \code{"ppp"}) with a \code{marks} vector that is a factor. } \details{ This function has the effect of classifying each point in the point pattern \code{x} into one of several possible types. The classification is based on the dataset \code{z}, which may be either \itemize{ \item a factor (of length equal to the number of points in \code{z}) determining the classification of each point in \code{x}. Levels of the factor determine the classification. \item a numeric vector (of length equal to the number of points in \code{z}). The range of values of \code{z} will be divided into bands (the number of bands is determined by \code{\dots}) and \code{z} will be converted to a factor using \code{\link{cut.default}}. \item a pixel image (object of class \code{"im"}). The value of \code{z} at each point of \code{x} will be used as the classifying variable. \item a tessellation (object of class \code{"tess"}, see \code{\link{tess}}). Each point of \code{x} will be classified according to the tile of the tessellation into which it falls. \item a window (object of class \code{"owin"}). Each point of \code{x} will be classified according to whether it falls inside or outside this window. \item a character string, giving the name of one of the columns of \code{marks(x)}, if this is a data frame. \item a character string \code{"x"} or \code{"y"} identifying one of the spatial coordinates. } The default is to take \code{z} to be the vector of marks in \code{x} (or the first column in the data frame of marks of \code{x}, if it is a data frame). If the marks are numeric, then the range of values of the numerical marks is divided into several intervals, and each interval is associated with a level of a factor. The result is a marked point pattern, with the same window and point locations as \code{x}, but with the numeric mark of each point discretised by replacing it by the factor level. This is a convenient way to transform a marked point pattern which has numeric marks into a multitype point pattern, for example to plot it or analyse it. See the examples. To select some points from a point pattern, use the subset operators \code{\link{[.ppp}} or \code{\link{subset.ppp}} instead. } \seealso{ \code{\link{cut}}, \code{\link{ppp.object}}, \code{\link{tess}} } \examples{ # (1) cutting based on numeric marks of point pattern trees <- longleaf # Longleaf Pines data # the marks are positive real numbers indicating tree diameters. \testonly{ # smaller dataset trees <- trees[seq(1, npoints(trees), by=80)] } if(interactive()) { plot(trees) } # cut the range of tree diameters into three intervals long3 <- cut(trees, breaks=3) if(interactive()) { plot(long3) } # adult trees defined to have diameter at least 30 cm long2 <- cut(trees, breaks=c(0,30,100), labels=c("Sapling", "Adult")) plot(long2) plot(long2, cols=c("green","blue")) # (2) cutting based on another numeric vector # Divide Swedish Pines data into 3 classes # according to nearest neighbour distance swedishpines plot(cut(swedishpines, nndist(swedishpines), breaks=3)) # (3) cutting based on tessellation # Divide Swedish Pines study region into a 4 x 4 grid of rectangles # and classify points accordingly tes <- tess(xgrid=seq(0,96,length=5),ygrid=seq(0,100,length=5)) plot(cut(swedishpines, tes)) plot(tes, lty=2, add=TRUE) # (4) inside/outside a given region with(murchison, cut(gold, greenstone)) # (5) multivariate marks finpines cut(finpines, "height", breaks=4) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} spatstat.geom/man/Extract.splitppp.Rd0000644000176200001440000000244314611065346017402 0ustar liggesusers\name{Extract.splitppp} \alias{[.splitppp} \alias{[<-.splitppp} \title{Extract or Replace Sub-Patterns} \description{ Extract or replace some of the sub-patterns in a split point pattern. } \usage{ \method{[}{splitppp}(x, ...) \method{[}{splitppp}(x, ...) <- value } \arguments{ \item{x}{ An object of class \code{"splitppp"}, representing a point pattern separated into a list of sub-patterns. } \item{\dots}{ Subset index. Any valid subset index in the usual \R sense. } \item{value}{ Replacement value for the subset. A list of point patterns. } } \value{ Another object of class \code{"splitppp"}. } \details{ These are subset methods for the class \code{"splitppp"}. The argument \code{x} should be an object of class \code{"splitppp"}, representing a point pattern that has been separated into a list of sub-patterns. It is created by \code{\link{split.ppp}}. The methods extract or replace a designated subset of the list \code{x}, and return an object of class \code{"splitppp"}. } \seealso{ \code{\link{split.ppp}}, \code{\link{plot.splitppp}}, \code{\link{summary.splitppp}} } \examples{ y <- split(amacrine) y[[1]] y[["off"]] y[[1]] <- rsyst(Window(amacrine), 4, 3) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/quantile.im.Rd0000644000176200001440000000203314611065350016332 0ustar liggesusers\name{quantile.im} \alias{quantile.im} \title{Sample Quantiles of Pixel Image} \description{ Compute the sample quantiles of the pixel values of a given pixel image. } \usage{ \method{quantile}{im}(x, \dots) } \arguments{ \item{x}{ A pixel image. An object of class \code{"im"}. } \item{\dots}{ Optional arguments passed to \code{\link{quantile.default}}. They determine the probabilities for which quantiles should be computed. See \code{\link{quantile.default}}. } } \value{ A vector of quantiles. } \details{ This simple function applies the generic \code{\link{quantile}} operation to the pixel values of the image \code{x}. This function is a convenient way to inspect an image and to obtain summary statistics. See the examples. } \seealso{ \code{\link{quantile}}, \code{\link{cut.im}}, \code{\link{im.object}} } \examples{ # artificial image data Z <- setcov(square(1)) # find the quartiles quantile(Z) # find the deciles quantile(Z, probs=(0:10)/10) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} \keyword{univar} spatstat.geom/man/hyperframe.Rd0000644000176200001440000001051714735371702016264 0ustar liggesusers\name{hyperframe} \alias{hyperframe} \title{Hyper Data Frame} \description{ Create a hyperframe: a two-dimensional array in which each column consists of values of the same atomic type (like the columns of a data frame) or objects of the same class. } \usage{ hyperframe(..., row.names=NULL, check.rows=FALSE, check.names=TRUE, stringsAsFactors=NULL) } \arguments{ \item{\dots}{ Arguments of the form \code{value} or \code{tag=value}. Each \code{value} is either an atomic vector, a factor, a list of objects of the same class, a single atomic value, or a single object. Each \code{value} will become a column of the array. The \code{tag} determines the name of the column. See Details. } \item{row.names,check.rows,check.names,stringsAsFactors}{ Arguments passed to \code{\link[base]{data.frame}} controlling the names of the rows, whether to check that rows are consistent, whether to check validity of the column names, and whether to convert character columns to factors. } } \details{ A hyperframe is like a data frame, except that its entries can be objects of any kind. A hyperframe is a two-dimensional array in which each column consists of values of one atomic type (as in a data frame) or consists of objects of one class. The arguments \code{\dots} are any number of arguments of the form \code{value} or \code{tag=value}. Each \code{value} will become a column of the array. The \code{tag} determines the name of the column. Each \code{value} can be either \itemize{ \item an atomic vector or factor (i.e. numeric vector, integer vector, character vector, logical vector, complex vector, factor, or an object of class \code{"Date"} or \code{"Surv"}) \item a list of objects which are all of the same class \item one atomic value, which will be replicated to make an atomic vector or factor \item one object, which will be replicated to make a list of objects. } All columns (vectors, factors and lists) must be of the same length, if their length is greater than 1. } \section{Methods for Hyperframes}{ There are methods for \code{print}, \code{plot}, \code{summary}, \code{with}, \code{split}, \code{[}, \code{[<-}, \code{[[}, \code{[[<-}, \code{$}, \code{$<-}, \code{names}, \code{as.data.frame} \code{as.list}, \code{cbind} and \code{rbind} for the class of hyperframes. There is also \code{is.hyperframe} and \code{\link{as.hyperframe}}. } \section{Handling Character Strings}{ The argument \code{stringsAsFactors} is a logical value (passed to \code{\link[base]{data.frame}}) specifying how to handle pixel values which are character strings. If \code{TRUE}, character values are interpreted as factor levels. If \code{FALSE}, they remain as character strings. The default values of \code{stringsAsFactors} depends on the version of \R. \itemize{ \item In \R versions \code{< 4.1.0} the factory-fresh default is \code{stringsAsFactors=FALSE} and the default can be changed by setting \code{options(stringsAsFactors=FALSE)}. \item in \R versions \code{>= 4.1.0} the default is \code{stringsAsFactors=FALSE} and there is no option to change the default. } } \value{ An object of class \code{"hyperframe"}. } \author{\adrian and \rolf } \seealso{ \code{\link{as.hyperframe}}, \code{\link{as.hyperframe.ppx}}, \code{\link{plot.hyperframe}}, \code{\link{[.hyperframe}}, \code{\link{with.hyperframe}}, \code{\link{split.hyperframe}}, \code{\link{as.data.frame.hyperframe}}, \code{\link{cbind.hyperframe}}, \code{\link{rbind.hyperframe}} } \examples{ # equivalent to a data frame hyperframe(X=1:10, Y=3) # list of functions hyperframe(f=list(sin, cos, tan)) # table of functions and matching expressions hyperframe(f=list(sin, cos, tan), e=list(expression(sin(x)), expression(cos(x)), expression(tan(x)))) hyperframe(X=1:10, Y=letters[1:10], Z=factor(letters[1:10]), stringsAsFactors=FALSE) lambda <- runif(4, min=50, max=100) if(require(spatstat.random)) { X <- solapply(as.list(lambda), rpoispp) } else { X <- solapply(as.list(lambda), function(lam) runifrect(rpois(1, lam))) } h <- hyperframe(lambda=lambda, X=X) h h$lambda2 <- lambda^2 h[, "lambda3"] <- lambda^3 h[, "Y"] <- X h[[2, "lambda3"]] } \keyword{spatial} \keyword{manip} spatstat.geom/man/edit.hyperframe.Rd0000644000176200001440000000223514611065346017203 0ustar liggesusers\name{edit.hyperframe} \alias{edit.hyperframe} \title{ Invoke Text Editor on Hyperframe } \description{ Invokes a text editor allowing the user to inspect and change entries in a hyperframe. } \usage{ \method{edit}{hyperframe}(name, \dots) } \arguments{ \item{name}{ A hyperframe (object of class \code{"hyperframe"}). } \item{\dots}{ Other arguments passed to \code{\link[utils]{edit.data.frame}}. } } \details{ The function \code{\link[utils]{edit}} is generic. This function is the methods for objects of class \code{"hyperframe"}. The hyperframe \code{name} is converted to a data frame or array, and the text editor is invoked. The user can change entries in the columns of data, and create new columns of data. Only the columns of atomic data (numbers, characters, factor values etc) can be edited. Note that the original object \code{name} is not changed; the function returns the edited dataset. } \value{ Another hyperframe. } \author{ \adrian \rolf and \ege } \seealso{ \code{\link[utils]{edit.data.frame}}, \code{\link{edit.ppp}} } \examples{ if(interactive()) Z <- edit(flu) } \keyword{spatial} \keyword{manip} spatstat.geom/man/npoints.Rd0000644000176200001440000000157314611065347015614 0ustar liggesusers\name{npoints} \alias{npoints} \alias{npoints.ppp} \alias{npoints.pp3} \alias{npoints.ppx} \title{Number of Points in a Point Pattern} \description{ Returns the number of points in a point pattern of any kind. } \usage{ npoints(x) \method{npoints}{ppp}(x) \method{npoints}{pp3}(x) \method{npoints}{ppx}(x) } \arguments{ \item{x}{ A point pattern (object of class \code{"ppp"}, \code{"pp3"}, \code{"ppx"} or some other suitable class). } } \value{ Integer. } \details{ This function returns the number of points in a point pattern. The function \code{npoints} is generic with methods for the classes \code{"ppp"}, \code{"pp3"}, \code{"ppx"} and possibly other classes. } \seealso{ \code{\link{ppp.object}}, \code{\link{print.pp3}}, \code{\link{print.ppx}}. } \examples{ npoints(cells) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.hyperframe.ppx.Rd0000644000176200001440000000467714611065345017502 0ustar liggesusers\name{as.hyperframe.ppx} \Rdversion{1.1} \alias{as.hyperframe.ppx} \alias{as.data.frame.ppx} \alias{as.matrix.ppx} \title{ Extract coordinates and marks of multidimensional point pattern } \description{ Given any kind of spatial or space-time point pattern, extract the coordinates and marks of the points. } \usage{ \method{as.hyperframe}{ppx}(x, ...) \method{as.data.frame}{ppx}(x, ...) \method{as.matrix}{ppx}(x, ...) } \arguments{ \item{x}{ A general multidimensional space-time point pattern (object of class \code{"ppx"}). } \item{\dots}{ Ignored. } } \details{ An object of class \code{"ppx"} (see \code{\link{ppx}}) represents a marked point pattern in multidimensional space and/or time. There may be any number of spatial coordinates, any number of temporal coordinates, and any number of mark variables. The individual marks may be atomic (numeric values, factor values, etc) or objects of any kind. The function \code{as.hyperframe.ppx} extracts the coordinates and the marks as a \code{"hyperframe"} (see \code{\link{hyperframe}}) with one row of data for each point in the pattern. This is a method for the generic function \code{\link{as.hyperframe}}. The function \code{as.data.frame.ppx} discards those mark variables which are not atomic values, and extracts the coordinates and the remaining marks as a \code{data.frame} with one row of data for each point in the pattern. This is a method for the generic function \code{\link{as.data.frame}}. Finally \code{as.matrix(x)} is equivalent to \code{as.matrix(as.data.frame(x))} for an object of class \code{"ppx"}. Be warned that, if there are any columns of non-numeric data (i.e. if there are mark variables that are factors), the result will be a matrix of character values. } \value{ A \code{hyperframe}, \code{data.frame} or \code{matrix} as appropriate. } \author{\adrian and \rolf } \seealso{ \code{\link{ppx}}, \code{\link{hyperframe}}, \code{\link{as.hyperframe}}. } \examples{ df <- data.frame(x=runif(4),y=runif(4),t=runif(4)) X <- ppx(data=df, coord.type=c("s","s","t")) as.data.frame(X) # ppx with marks which are point patterns val <- runif(4, max=10) num <- sapply(val, rpois, n=1) E <- lapply(num, runifrect) hf <- hyperframe(t=val, e=as.listof(E)) Z <- ppx(data=hf, domain=c(0,10)) # convert ppx to a hyperframe as.hyperframe(Z) as.data.frame(Z) } \keyword{spatial} \keyword{manip} spatstat.geom/man/tess.Rd0000644000176200001440000001373414676150557015113 0ustar liggesusers\name{tess} \alias{tess} \title{Create a Tessellation} \description{ Creates an object of class \code{"tess"} representing a tessellation of a spatial region. } \usage{ tess(..., xgrid = NULL, ygrid = NULL, tiles = NULL, image = NULL, window=NULL, marks=NULL, keepempty=FALSE, unitname=NULL, check=TRUE) } \arguments{ \item{\dots}{Ignored.} \item{xgrid,ygrid}{Cartesian coordinates of vertical and horizontal lines determining a grid of rectangles. Incompatible with other arguments. } \item{tiles}{List of tiles in the tessellation. A list, each of whose elements is a window (object of class \code{"owin"}). Incompatible with other arguments. } \item{image}{ Pixel image (object of class \code{"im"}) which specifies the tessellation. Incompatible with other arguments. } \item{window}{ Optional. The spatial region which is tessellated (i.e. the union of all the tiles). An object of class \code{"owin"}. } \item{marks}{ Optional vector, data frame or hyperframe of marks associated with the tiles. } \item{keepempty}{ Logical flag indicating whether empty tiles should be retained or deleted. } \item{unitname}{ Optional. Name of unit of length. Either a single character string, or a vector of two character strings giving the singular and plural forms, respectively. If this argument is missing or \code{NULL}, information about the unitname will be extracted from the other arguments. If this argument is given, it overrides any other information about the unitname. } \item{check}{ Logical value indicating whether to check the validity of the input data. It is strongly recommended to use the default value \code{check=TRUE}. } } \details{ A tessellation is a collection of disjoint spatial regions (called \emph{tiles}) that fit together to form a larger spatial region. This command creates an object of class \code{"tess"} that represents a tessellation. Three types of tessellation are supported: \describe{ \item{rectangular:}{ tiles are rectangles, with sides parallel to the \code{x} and \code{y} axes. They may or may not have equal size and shape. The arguments \code{xgrid} and \code{ygrid} determine the positions of the vertical and horizontal grid lines, respectively. (See \code{\link{quadrats}} for another way to do this.) } \item{tile list:}{ tiles are arbitrary spatial regions. The argument \code{tiles} is a list of these tiles, which are objects of class \code{"owin"}. } \item{pixel image:}{ Tiles are subsets of a fine grid of pixels. The argument \code{image} is a pixel image (object of class \code{"im"}) with factor values. Each level of the factor represents a different tile of the tessellation. The pixels that have a particular value of the factor constitute a tile. } } The optional argument \code{window} specifies the spatial region formed by the union of all the tiles. In other words it specifies the spatial region that is divided into tiles by the tessellation. If this argument is missing or \code{NULL}, it will be determined by computing the set union of all the tiles. This is a time-consuming computation. For efficiency it is advisable to specify the window. Note that the validity of the window will not be checked. Empty tiles may occur, either because one of the entries in the list \code{tiles} is an empty window, or because one of the levels of the factor-valued pixel image \code{image} does not occur in the pixel data. When \code{keepempty=TRUE}, empty tiles are permitted. When \code{keepempty=FALSE} (the default), tiles are not allowed to be empty, and any empty tiles will be removed from the tessellation. There are methods for \code{print}, \code{plot}, \code{[} and \code{[<-} for tessellations. Use \code{\link{tiles}} to extract the list of tiles in a tessellation, \code{\link{tilenames}} to extract the names of the tiles, and \code{\link{tile.areas}} to compute their areas. The tiles may have marks, which can be extracted by \code{\link{marks.tess}} and changed by \code{\link{marks<-.tess}}. Tessellations can be used to classify the points of a point pattern, in \code{\link{split.ppp}}, \code{\link{cut.ppp}} and \code{\link{by.ppp}}. To construct particular tessellations, see \code{\link{quadrats}}, \code{\link{hextess}}, \code{\link{dirichlet}}, \code{\link{delaunay}}, \code{\link{venn.tess}}, \code{\link{polartess}}, \code{\link{quantess}}, \code{\link{bufftess}} and \code{\link[spatstat.random]{rpoislinetess}}. } \value{ An object of class \code{"tess"} representing the tessellation. } \seealso{ \code{\link{marks.tess}}, \code{\link{plot.tess}}, \code{\link{[.tess}}, \code{\link{as.tess}}, \code{\link{tiles}}, \code{\link{intersect.tess}}, \code{\link{split.ppp}}, \code{\link{cut.ppp}}, \code{\link{by.ppp}}, \code{\link{bdist.tiles}}, \code{\link{tile.areas}}, \code{\link{as.function.tess}}. To construct particular tessellations, see \code{\link{quadrats}}, \code{\link{hextess}}, \code{\link{venn.tess}}, \code{\link{polartess}}, \code{\link{dirichlet}}, \code{\link{delaunay}}, \code{\link{quantess}} and \code{\link[spatstat.random]{rpoislinetess}}. To divide space into pieces containing equal amounts of stuff, use \code{\link{quantess}}. To convert a tessellation to a function, for use as a spatial covariate (associating a numerical value with each tile of the tessellation) use \code{\link{as.function.tess}}. } \examples{ A <- tess(xgrid=0:4,ygrid=0:4) A plot(A) B <- A[c(1, 2, 5, 7, 9)] B v <- as.im(function(x,y){factor(round(5 * (x^2 + y^2)))}, W=owin()) levels(v) <- letters[seq(length(levels(v)))] E <- tess(image=v) plot(E) G <- tess(image=v, marks=toupper(levels(v)), unitname="km") G } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{datagen} \concept{Tessellation} spatstat.geom/man/edit.ppp.Rd0000644000176200001440000000312114611065346015633 0ustar liggesusers\name{edit.ppp} \alias{edit.ppp} \alias{edit.psp} \alias{edit.im} \title{ Invoke Text Editor on Spatial Data } \description{ Invokes a text editor allowing the user to inspect and change entries in a spatial dataset. } \usage{ \method{edit}{ppp}(name, \dots) \method{edit}{psp}(name, \dots) \method{edit}{im}(name, \dots) } \arguments{ \item{name}{ A spatial dataset (object of class \code{"ppp"}, \code{"psp"} or \code{"im"}). } \item{\dots}{ Other arguments passed to \code{\link[utils]{edit.data.frame}}. } } \details{ The function \code{\link[utils]{edit}} is generic. These functions are methods for spatial objects of class \code{"ppp"}, \code{"psp"} and \code{"im"}. The spatial dataset \code{name} is converted to a data frame or array, and the text editor is invoked. The user can change the values of spatial coordinates or marks of the points in a point pattern, or the coordinates or marks of the segments in a segment pattern, or the pixel values in an image. The names of the columns of marks can also be edited. If \code{name} is a pixel image, it is converted to a matrix and displayed in the same spatial orientation as if the image had been plotted. Note that the original object \code{name} is not changed; the function returns the edited dataset. } \value{ Object of the same kind as \code{name} containing the edited data. } \author{ \adrian \rolf and \ege } \seealso{ \code{\link[utils]{edit.data.frame}}, \code{\link{edit.hyperframe}} } \examples{ if(interactive()) Z <- edit(cells) } \keyword{spatial} \keyword{manip} spatstat.geom/man/quasirandom.Rd0000644000176200001440000000621014611065350016430 0ustar liggesusers\name{quasirandom} \alias{quasirandom} %DoNotExport \alias{vdCorput} \alias{Halton} \alias{Hammersley} \title{ Quasirandom Patterns } \description{ Generates quasirandom sequences of numbers and quasirandom spatial patterns of points in any dimension. } \usage{ vdCorput(n, base) Halton(n, bases = c(2, 3), raw = FALSE, simplify = TRUE) Hammersley(n, bases = 2, raw = FALSE, simplify = TRUE) } \arguments{ \item{n}{ Number of points to generate. } \item{base}{ A prime number giving the base of the sequence. } \item{bases}{ Vector of prime numbers giving the bases of the sequences for each coordinate axis. } \item{raw}{ Logical value indicating whether to return the coordinates as a matrix (\code{raw=TRUE}) or as a spatial point pattern (\code{raw=FALSE}, the default). } \item{simplify}{ Argument passed to \code{\link{ppx}} indicating whether point patterns of dimension 2 or 3 should be returned as objects of class \code{"ppp"} or \code{"pp3"} respectively (\code{simplify=TRUE}, the default) or as objects of class \code{"ppx"} (\code{simplify=FALSE}). } } \details{ The function \code{vdCorput} generates the quasirandom sequence of Van der Corput (1935) of length \code{n} with the given \code{base}. These are numbers between 0 and 1 which are in some sense uniformly distributed over the interval. The function \code{Halton} generates the Halton quasirandom sequence of points in \code{d}-dimensional space, where \code{d = length(bases)}. The values of the \eqn{i}-th coordinate of the points are generated using the van der Corput sequence with base equal to \code{bases[i]}. The function \code{Hammersley} generates the Hammersley set of points in \code{d+1}-dimensional space, where \code{d = length(bases)}. The first \code{d} coordinates of the points are generated using the van der Corput sequence with base equal to \code{bases[i]}. The \code{d+1}-th coordinate is the sequence \code{1/n, 2/n, ..., 1}. If \code{raw=FALSE} (the default) then the Halton and Hammersley sets are interpreted as spatial point patterns of the appropriate dimension. They are returned as objects of class \code{"ppx"} (multidimensional point patterns) unless \code{simplify=TRUE} and \code{d=2} or \code{d=3} when they are returned as objects of class \code{"ppp"} or \code{"pp3"}. If \code{raw=TRUE}, the coordinates are returned as a matrix with \code{n} rows and \code{D} columns where \code{D} is the spatial dimension. } \value{ For \code{vdCorput}, a numeric vector. For \code{Halton} and \code{Hammersley}, an object of class \code{"ppp"}, \code{"pp3"} or \code{"ppx"}; or if \code{raw=TRUE}, a numeric matrix. } \references{ Van der Corput, J. G. (1935) Verteilungsfunktionen. \emph{Proc. Ned. Akad. v. Wetensch.} \bold{38}: 813--821. Kuipers, L. and Niederreiter, H. (2005) \emph{Uniform distribution of sequences}, Dover Publications. } \seealso{ \code{\link{rQuasi}} } \examples{ vdCorput(10, 2) plot(Halton(256, c(2,3))) plot(Hammersley(256, 3)) } \author{\adrian , \rolf and \ege. } \keyword{spatial} \keyword{datagen} spatstat.geom/man/plot.symbolmap.Rd0000644000176200001440000000742614721742045017104 0ustar liggesusers\name{plot.symbolmap} \alias{plot.symbolmap} \title{ Plot a Graphics Symbol Map } \description{ Plot a representation of a graphics symbol map, similar to a plot legend. } \usage{ \method{plot}{symbolmap}(x, \dots, main, xlim = NULL, ylim = NULL, vertical = FALSE, side = c("bottom", "left", "top", "right"), annotate = TRUE, labelmap = NULL, add = FALSE, nsymbols = NULL, warn = TRUE, colour.only=FALSE, representatives=NULL) } \arguments{ \item{x}{ Graphics symbol map (object of class \code{"symbolmap"}). } \item{\dots}{ Additional graphics arguments passed to \code{\link{points}}, \code{\link{symbols}} or \code{\link{axis}}. } \item{main}{ Main title for the plot. A character string. } \item{xlim,ylim}{ Coordinate limits for the plot. Numeric vectors of length 2. } \item{vertical}{ Logical. Whether to plot the symbol map in a vertical orientation. } \item{side}{ Character string specifying the position of the text that annotates the symbols. Alternatively one of the integers 1 to 4. } \item{annotate}{ Logical. Whether to annotate the symbols with labels. } \item{labelmap}{ Transformation of the labels. A function or a scale factor which will be applied to the data values corresponding to the plotted symbols. } \item{add}{ Logical value indicating whether to add the plot to the current plot (\code{add=TRUE}) or to initialise a new plot. } \item{nsymbols}{ Optional. The maximum number of symbols that should be displayed. Ignored if \code{representatives} are given. } \item{warn}{ Logical value specifying whether to issue a warning when the plotted symbol map does not represent every possible discrete value. } \item{colour.only}{ Logical value. If \code{TRUE}, the colour map information will be extracted from the symbol map, and only this colour map will be plotted. If \code{FALSE} (the default) the entire symbol map is plotted, including information about symbol shape and size as well as colour. } \item{representatives}{ Optional. Vector containing the values of the input data which should be shown on the plot. } } \details{ A graphics symbol map (object of class \code{"symbolmap"}) is an association between data values and graphical symbols. This command plots the graphics symbol map itself, in the style of a plot legend. For a map of continuous values (a symbol map which represents a range of numerical values) the plot will select about \code{nsymbols} different values within this range, and plot their graphical representations. For a map of discrete inputs (a symbol map which represents a finite set of elements, such as categorical values) the plot will try to display the graphical representation of every possible input, up to a maximum of \code{nsymbols} items. If there are more than \code{nsymbols} possible inputs, a warning will be issued (if \code{warn=TRUE}, the default). } \value{ None. } \author{ \spatstatAuthors. } \seealso{ \code{\link{symbolmap}} to create a symbol map. \code{\link{invoke.symbolmap}} to apply the symbol map to some data and plot the resulting symbols. } \examples{ g <- symbolmap(inputs=letters[1:10], pch=11:20) plot(g) g2 <- symbolmap(range=c(-1,1), shape=function(x) ifelse(x > 0, "circles", "squares"), size=function(x) sqrt(ifelse(x > 0, x/pi, -x)), bg = function(x) ifelse(abs(x) < 1, "red", "black")) plot(g2, vertical=TRUE, side="left", col.axis="blue", cex.axis=2) plot(g2, representatives=c(-1,0,1)) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/Extract.listof.Rd0000644000176200001440000000212614611065346017025 0ustar liggesusers\name{Extract.listof} \alias{[<-.listof} \title{Extract or Replace Subset of a List of Things} \description{ Replace a subset of a list of things. } \usage{ \method{[}{listof}(x, i) <- value } \arguments{ \item{x}{ An object of class \code{"listof"} representing a list of things which all belong to one class. } \item{i}{ Subset index. Any valid subset index in the usual \R sense. } \item{value}{ Replacement value for the subset. } } \value{ Another object of class \code{"listof"}. } \details{ This is a subset replacement method for the class \code{"listof"}. The argument \code{x} should be an object of class \code{"listof"} representing a list of things that all belong to one class. The method replaces a designated subset of \code{x}, and returns an object of class \code{"listof"}. } \seealso{ \code{\link{plot.listof}}, \code{\link{summary.listof}} } \examples{ x <- list(A=runif(10), B=runif(10), C=runif(10)) class(x) <- c("listof", class(x)) x[1] <- list(A=rnorm(10)) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/methods.funxy.Rd0000644000176200001440000000367214765164151016742 0ustar liggesusers\name{methods.funxy} \alias{methods.funxy} %DoNotExport \alias{contour.funxy} \alias{persp.funxy} \alias{plot.funxy} \Rdversion{1.1} \title{ Methods for Spatial Functions } \description{ Methods for objects of the class \code{"funxy"}. } \usage{ \method{contour}{funxy}(x, \dots) \method{persp}{funxy}(x, \dots) \method{plot}{funxy}(x, \dots) } \arguments{ \item{x}{ Object of class \code{"funxy"} representing a function of \eqn{x,y} coordinates. } \item{\dots}{ Named arguments controlling the plot. See Details. } } \details{ These are methods for the generic functions \code{\link{plot}}, \code{\link{contour}} and \code{\link{persp}} for the class \code{"funxy"} of spatial functions. Objects of class \code{"funxy"} are created, for example, by the commands \code{\link{distfun}} and \code{\link{funxy}}. The \code{plot}, \code{contour} and \code{persp} methods first convert \code{x} to a pixel image object using \code{\link{as.im}}, then display it using \code{\link{plot.im}}, \code{\link{contour.im}} or \code{\link{persp.im}}. Additional arguments \code{\dots} are either passed to \code{\link{as.im.function}} to control the spatial resolution of the pixel image, or passed to \code{\link{contour.im}}, \code{\link{persp.im}} or \code{\link{plot.im}} to control the appearance of the plot. In particular the argument \code{W} specifies the spatial domain over which the function will be plotted. See the Examples. } \value{ \code{NULL}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{funxy}}, \code{\link{distfun}}, \code{\link{as.im}}, \code{\link{plot.im}}, \code{\link{persp.im}}, \code{\link{contour.im}}, \code{\link{spatstat.options}} } \examples{ f <- distfun(letterR) contour(f) ## plot it on a larger region B <- owin(c(1,5), c(-1, 4)) contour(f, W=B) persp(f, W=B, theta=40, phi=40, border=NA, shade=0.7) } \keyword{spatial} \keyword{methods} spatstat.geom/man/imcov.Rd0000644000176200001440000000334614611065346015236 0ustar liggesusers\name{imcov} \alias{imcov} \title{Spatial Covariance of a Pixel Image} \description{ Computes the unnormalised spatial covariance function of a pixel image. } \usage{ imcov(X, Y=X) } \arguments{ \item{X}{ A pixel image (object of class \code{"im"}. } \item{Y}{ Optional. Another pixel image. } } \value{ A pixel image (an object of class \code{"im"}) representing the spatial covariance function of \code{X}, or the cross-covariance of \code{X} and \code{Y}. } \details{ The (uncentred, unnormalised) \emph{spatial covariance function} of a pixel image \eqn{X} in the plane is the function \eqn{C(v)} defined for each vector \eqn{v} as \deqn{ C(v) = \int X(u)X(u-v)\, {\rm d}u }{ C(v) = integral of X(u) * X(u-v) du } where the integral is over all spatial locations \eqn{u}, and where \eqn{X(u)} denotes the pixel value at location \eqn{u}. This command computes a discretised approximation to the spatial covariance function, using the Fast Fourier Transform. The return value is another pixel image (object of class \code{"im"}) whose greyscale values are values of the spatial covariance function. If the argument \code{Y} is present, then \code{imcov(X,Y)} computes the set \emph{cross-covariance} function \eqn{C(u)} defined as \deqn{ C(v) = \int X(u)Y(u-v)\, {\rm d}u. }{ C(v) = integral of X(u) * Y(u-v) du. } Note that \code{imcov(X,Y)} is equivalent to \code{convolve.im(X,Y,reflectY=TRUE)}. } \seealso{ \code{\link{setcov}}, \code{\link{convolve.im}}, \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{erosion}} } \examples{ X <- as.im(square(1)) v <- imcov(X) plot(v) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/plot.yardstick.Rd0000644000176200001440000001025114755302430017061 0ustar liggesusers\name{plot.yardstick} \alias{plot.yardstick} \title{ Plot a Yardstick or Scale Bar } \description{ Plots an object of class \code{"yardstick"}. } \usage{ \method{plot}{yardstick}(x, \dots, style=c("arrows", "zebra"), angle = 20, frac = 1/8, split = FALSE, shrink = 1/4, zebra.step=NULL, zebra.width=NULL, zebra.col="black", pos = NULL, txt.args=list(), txt.shift=c(0,0), do.plot = TRUE) } \arguments{ \item{x}{ Object of class \code{"yardstick"} to be plotted. This object is created by the command \code{\link{yardstick}}. } \item{\dots}{ Additional graphics arguments passed to \code{\link[graphics]{segments}} to control the appearance of the line. } \item{style}{ Character string (partially matched) specifying the style of plot. See Details. } \item{angle}{ Angle between the arrows and the line segment, in degrees. Applies when \code{style="arrows"}. } \item{frac}{ Length of arrow as a fraction of total length of the line segment. Applies when \code{style="arrows"}. } \item{split}{ Logical. If \code{TRUE}, then the line will be broken in the middle, and the text will be placed in this gap. If \code{FALSE}, the line will be unbroken, and the text will be placed beside the line. Applies when \code{style="arrows"}. } \item{shrink}{ Fraction of total length to be removed from the middle of the line segment, if \code{split=TRUE}. Applies when \code{style="arrows"}. } \item{zebra.step}{ Length of each bar in the zebra pattern. Applies when \code{style="zebra"}. } \item{zebra.width}{ Width of each bar in the zebra pattern. Applies when \code{style="zebra"}. } \item{zebra.col}{ Colour of each bar in the zebra pattern. Applies when \code{style="zebra"}. } \item{pos}{ Integer (passed to \code{\link[graphics]{text}}) determining the position of the annotation text relative to the line segment, if \code{split=FALSE}. Values of 1, 2, 3 and 4 indicate positions below, to the left of, above and to the right of the line, respectively. } \item{txt.args}{ Optional list of additional arguments passed to \code{\link[graphics]{text}} controlling the appearance of the text. Examples include \code{adj}, \code{srt}, \code{col}, \code{cex}, \code{font}. } \item{txt.shift}{ Optional numeric vector of length 2 specifying displacement of the text position relative to the centre of the yardstick. } \item{do.plot}{ Logical. Whether to actually perform the plot (\code{do.plot=TRUE}). } } \details{ A yardstick or scale bar is a line segment, drawn on any spatial graphics display, indicating the scale of the plot. \itemize{ \item If \code{style="arrows"}, the line segment is drawn as a pair of arrows pointing from the middle of the line to the ends of the line. This style is often used in architectural drawings. If \code{angle=0}, the arrow heads are replaced by parallel bars marking the two ends of the line. \item If \code{style="zebra"}, the line segment is divided into block of length \code{zebra.step} and width \code{zebra.width} units. Blocks are drawn alternately as filled rectangles and outlined rectangles, so that the result resembles a zebra crossing. This style is often used in maps and charts. There are sensible defaults for \code{zebra.step} and \code{zebra.width}. } The argument \code{x} should be an object of class \code{"yardstick"} created by the command \code{\link{yardstick}}. } \value{ A window (class \code{"owin"}) enclosing the plotted graphics. } \examples{ plot(owin(), main="Yardsticks") ys <- yardstick(as.psp(list(xmid=0.5, ymid=0.1, length=0.4, angle=0), window=owin(c(0.2, 0.8), c(0, 0.2))), txt="1 km") plot(ys) ys <- shift(ys, c(0, 0.3)) plot(ys, angle=90, frac=0.08) ys <- shift(ys, c(0, 0.3)) plot(ys, split=TRUE) yt <- shift(ys, c(0, 0.2)) plot(yt, style="z", pos=3, zebra.step=0.1, txt.args=list(offset=0.1)) } \author{\spatstatAuthors.} \seealso{ \code{\link{yardstick}} } \keyword{spatial} \keyword{hplot} spatstat.geom/man/as.function.tess.Rd0000644000176200001440000000341514765164151017326 0ustar liggesusers\name{as.function.tess} \alias{as.function.tess} \title{ Convert a Tessellation to a Function } \description{ Convert a tessellation into a function of the \eqn{x} and \eqn{y} coordinates. The default function values are factor levels specifying which tile of the tessellation contains the point \eqn{(x,y)}. } \usage{ \method{as.function}{tess}(x,\dots,values=NULL) } \arguments{ \item{x}{ A tessellation (object of class \code{"tess"}). } \item{values}{ Optional. A vector giving the values of the function for each tile of \code{x}. } \item{\dots}{ Ignored. } } \details{ This command converts a tessellation (object of class \code{"tess"}) to a \code{function(x,y)} where the arguments \code{x} and \code{y} are (vectors of) spatial coordinates. The corresponding function values are factor levels identifying which tile of the tessellation contains each point. Values are \code{NA} if the corresponding point lies outside the tessellation. If the argument \code{values} is given, then it determines the value of the function in each tile of \code{x}. } \value{ A function in the \R language, also belonging to the class \code{"funxy"} and \code{"tessfun"}. The class \code{"tessfun"} has methods for \code{plot}, \code{print}, \code{as.tess} and \code{integral}. } \author{ \spatstatAuthors } \seealso{ \code{\link{integral.tessfun}} for integration of the function. \code{\link{tileindex}} for the low-level calculation of tile index. \code{\link{cut.ppp}} and \code{\link{split.ppp}} to divide up the points of a point pattern according to a tessellation. } \examples{ X <- runifrect(7) V <- dirichlet(X) f <- as.function(V) f(0.1, 0.4) plot(f) } \keyword{spatial} \keyword{manip} \concept{Tessellation} spatstat.geom/man/bdist.pixels.Rd0000644000176200001440000000635614643111575016536 0ustar liggesusers\name{bdist.pixels} \alias{bdist.pixels} \title{Distance to Boundary of Window} \description{ Computes the distances from each pixel in a window to the boundary of the window. } \usage{ bdist.pixels(w, \dots, style=c("image", "matrix", "coords"), method=c("C", "interpreted")) } \arguments{ \item{w}{A window (object of class \code{"owin"}).} \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution.} \item{style}{ Character string (partially matched) determining the format of the output: either \code{"matrix"}, \code{"coords"} or \code{"image"}. } \item{method}{Choice of algorithm to use when \code{w} is polygonal.} } \value{ If \code{style="image"}, a pixel image (object of class \code{"im"}) containing the distances from each pixel in the image raster to the boundary of the window. If \code{style="matrix"}, a matrix giving the distances. Rows of this matrix correspond to the \eqn{y} coordinate and columns to the \eqn{x} coordinate. If \code{style="coords"}, a list with three components \code{x,y,z}, where \code{x,y} are vectors of length \eqn{m,n} giving the \eqn{x} and \eqn{y} coordinates respectively, and \code{z} is an \eqn{m \times n}{m x n} matrix such that \code{z[i,j]} is the distance from \code{(x[i],y[j])} to the boundary of the window. Rows of this matrix correspond to the \eqn{x} coordinate and columns to the \eqn{y} coordinate. This result can be plotted with \code{persp}, \code{image} or \code{contour}. } \details{ This function computes, for each pixel \eqn{u} in the Frame containing the window \code{w}, the shortest distance \eqn{d(u, w^c)}{dist(u, w')} from \eqn{u} to the complement of \eqn{w}. This value is zero for pixels lying outside \code{w}, and is positive for pixels inside \code{w}. If the window is a binary mask then the distance from each pixel to the boundary is computed using the distance transform algorithm \code{\link{distmap.owin}}. The result is equivalent to \code{distmap(W, invert=TRUE)}. If the window is a rectangle or a polygonal region, the grid of pixels is determined by the arguments \code{"\dots"} passed to \code{\link[spatstat.geom]{as.mask}}. The distance from each pixel to the boundary is calculated exactly, using analytic geometry. This is slower but more accurate than in the case of a binary mask. For software testing purposes, there are two implementations available when \code{w} is a polygon: the default is \code{method="C"} which is much faster than \code{method="interpreted"}. To compute the distance from each pixel to the bounding rectangular frame \code{Frame(W)}, use \code{\link{framedist.pixels}}. } \seealso{ \code{\link{framedist.pixels}} \code{\link{owin.object}}, \code{\link{erosion}}, \code{\link{bdist.points}}, \code{\link{bdist.tiles}}, \code{\link{distmap.owin}}. } \examples{ u <- owin(c(0,1),c(0,1)) d <- bdist.pixels(u, eps=0.01) image(d) d <- bdist.pixels(u, eps=0.01, style="matrix") mean(d >= 0.1) # value is approx (1 - 2 * 0.1)^2 = 0.64 opa <- par(mfrow=c(1,2)) plot(bdist.pixels(letterR)) plot(framedist.pixels(letterR)) par(opa) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/tweak.colourmap.Rd0000644000176200001440000000277714611065351017237 0ustar liggesusers\name{tweak.colourmap} \alias{tweak.colourmap} \title{ Change Colour Values in a Colour Map } \description{ Assign new colour values to some of the entries in a colour map. } \usage{ tweak.colourmap(m, col, ..., inputs=NULL, range=NULL) } \arguments{ \item{m}{ A colour map (object of class \code{"colourmap"}). } \item{inputs}{ Input values to the colour map, to be assigned new colours. Incompatible with \code{range}. } \item{range}{ Numeric vector of length 2 specifying a range of numerical values which should be assigned a new colour. Incompatible with \code{inputs}. } \item{col}{ Replacement colours for the specified \code{inputs} or the specified \code{range} of values. } \item{\dots}{Other arguments are ignored.} } \details{ This function changes the colour map \code{m} by assigning new colours to each of the input values specified by \code{inputs}, or by assigning a single new colour to the range of input values specified by \code{range}. The modified colour map is returned. } \value{ Another colour map (object of class \code{"colourmap"}). } \seealso{ \code{\link{colourmap}}, \code{\link{interp.colourmap}}, \code{\link{colouroutputs}}, \code{\link[spatstat.geom:colourtools]{colourtools}}. } \examples{ co <- colourmap(rainbow(32), range=c(0,1)) plot(tweak.colourmap(co, inputs=c(0.5, 0.6), "white")) plot(tweak.colourmap(co, range=c(0.5,0.6), "white")) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{color} spatstat.geom/man/colourmap.Rd0000644000176200001440000001165614723211063016116 0ustar liggesusers\name{colourmap} \alias{colourmap} \title{Colour Lookup Tables} \description{ Create a colour map (colour lookup table). } \usage{ colourmap(col, \dots, range=NULL, breaks=NULL, inputs=NULL, gamma=1) } \arguments{ \item{col}{Vector of values specifying colours} \item{\dots}{Ignored.} \item{range}{ Interval to be mapped. A numeric vector of length 2, specifying the endpoints of the range of values to be mapped. Incompatible with \code{breaks} or \code{inputs}. } \item{inputs}{ Values to which the colours are associated. A factor or vector of the same length as \code{col}. Incompatible with \code{breaks} or \code{range}. } \item{breaks}{ Breakpoints for the colour map. A numeric vector of length equal to \code{length(col)+1}. Incompatible with \code{range} or \code{inputs}. } \item{gamma}{ Exponent for the gamma correction, when \code{range} is given. A single positive number. See Details. } } \details{ A colour map is a mechanism for associating colours with data. It can be regarded as a function, mapping data to colours. The command \code{colourmap} creates an object representing a colour map, which can then be used to control the plot commands in the \pkg{spatstat} package. It can also be used to compute the colour assigned to any data value. The argument \code{col} specifies the colours to which data values will be mapped. It should be a vector whose entries can be interpreted as colours by the standard \R graphics system. The entries can be string names of colours like \code{"red"}, or integers that refer to colours in the standard palette, or strings containing six-letter hexadecimal codes like \code{"#F0A0FF"}. Exactly one of the arguments \code{range}, \code{inputs} or \code{breaks} must be specified by name. \itemize{ \item If \code{inputs} is given, then it should be a vector or factor, of the same length as \code{col}. The entries of \code{inputs} can be any atomic type (e.g. numeric, logical, character, complex) or factor values. The resulting colour map associates the value \code{inputs[i]} with the colour \code{col[i]}. The argument \code{col} should have the same length as \code{inputs}. \item If \code{range} is given, then it determines the interval of the real number line that will be mapped. It should be a numeric vector of length 2. The interval will be divided evenly into bands, each of which is assigned one of the colours in \code{col}. (If \code{gamma} is given, then the bands are equally spaced on a scale where the original values are raised to the power \code{gamma}.) \item If \code{breaks} is given, then it determines the precise intervals of the real number line which are mapped to each colour. It should be a numeric vector, of length at least 2, with entries that are in increasing order. Infinite values are allowed. Any number in the range between \code{breaks[i]} and \code{breaks[i+1]} will be mapped to the colour \code{col[i]}. The argument \code{col} should have length equal to \code{length(breaks) - 1}. } It is also permissible for \code{col} to be a single colour value, representing a trivial colour map in which all data values are mapped to the same colour. The result is an object of class \code{"colourmap"}. There are \code{print} and \code{plot} methods for this class. Some plot commands in the \pkg{spatstat} package accept an object of this class as a specification of the colour map. The result is also a function \code{f} which can be used to compute the colour assigned to any data value. That is, \code{f(x)} returns the character value of the colour assigned to \code{x}. This also works for vectors of data values. } \value{ A function, which is also an object of class \code{"colourmap"}. } \seealso{ The plot method \code{\link{plot.colourmap}}. See the \R help file on \code{\link[grDevices:colors]{colours}} for information about the colours that \R recognises, and how to manipulate them. To make a smooth transition between colours, see \code{\link{interp.colourmap}}. To alter individual colour values, see \code{\link{tweak.colourmap}}. To extract or replace all colour values, see \code{\link{colouroutputs}}. See also \code{\link{restrict.colourmap}} and \code{\link{rev.colourmap}}. See \code{\link[spatstat.geom:colourtools]{colourtools}} for more tools to manipulate colour values. See \code{\link{lut}} for lookup tables. } \examples{ # colour map for real numbers, using breakpoints cr <- colourmap(c("red", "blue", "green"), breaks=c(0,5,10,15)) cr cr(3.2) cr(c(3,5,7)) # a large colour map co <- colourmap(rainbow(100), range=c(-1,1)) co(0.2) # colour map for discrete set of values ct <- colourmap(c("red", "green"), inputs=c(FALSE, TRUE)) ct(TRUE) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{color} spatstat.geom/man/crossdist.pp3.Rd0000644000176200001440000000430114611065345016626 0ustar liggesusers\name{crossdist.pp3} \alias{crossdist.pp3} \title{Pairwise distances between two different three-dimensional point patterns} \description{ Computes the distances between pairs of points taken from two different three-dimensional point patterns. } \usage{ \method{crossdist}{pp3}(X, Y, \dots, periodic=FALSE, squared=FALSE) } \arguments{ \item{X,Y}{ Point patterns in three dimensions (objects of class \code{"pp3"}). } \item{\dots}{ Ignored. } \item{periodic}{ Logical. Specifies whether to apply a periodic edge correction. } \item{squared}{ Logical. If \code{squared=TRUE}, the squared distances are returned instead (this computation is faster). } } \value{ A matrix whose \code{[i,j]} entry is the distance from the \code{i}-th point in \code{X} to the \code{j}-th point in \code{Y}. } \details{ Given two point patterns in three-dimensional space, this function computes the Euclidean distance from each point in the first pattern to each point in the second pattern, and returns a matrix containing these distances. This is a method for the generic function \code{\link{crossdist}} for three-dimensional point patterns (objects of class \code{"pp3"}). This function expects two point patterns \code{X} and \code{Y}, and returns the matrix whose \code{[i,j]} entry is the distance from \code{X[i]} to \code{Y[j]}. Alternatively if \code{periodic=TRUE}, then provided the windows containing \code{X} and \code{Y} are identical and are rectangular, then the distances will be computed in the `periodic' sense (also known as `torus' distance): opposite edges of the rectangle are regarded as equivalent. This is meaningless if the window is not a rectangle. } \seealso{ \code{\link{crossdist}}, \code{\link{pairdist}}, \code{\link{nndist}}, \code{\link[spatstat.explore]{G3est}} } \examples{ if(require(spatstat.random)) { X <- runifpoint3(20) Y <- runifpoint3(30) } else { X <- osteo$pts[[1]] Y <- osteo$pts[[2]] Y <- Y[domain(X)] } d <- crossdist(X, Y) d <- crossdist(X, Y, periodic=TRUE) } \author{ \adrian based on code for two dimensions by \pavel. } \keyword{spatial} \keyword{math} \concept{Three-dimensional} spatstat.geom/man/rectdistmap.Rd0000644000176200001440000000213314611065350016424 0ustar liggesusers\name{rectdistmap} \alias{rectdistmap} \title{ Distance Map Using Rectangular Distance Metric } \description{ Computes the distance map of a spatial region based on the rectangular distance metric. } \usage{ rectdistmap(X, asp = 1, npasses=1, verbose=FALSE) } \arguments{ \item{X}{ A window (object of class \code{"owin"}). } \item{asp}{ Aspect ratio for the metric. See Details. } \item{npasses}{ Experimental. } \item{verbose}{ Logical value indicating whether to print trace information. } } \details{ This function computes the distance map of the spatial region \code{X} using the rectangular distance metric with aspect ratio \code{asp}. This metric is defined so that the set of all points lying at most 1 unit away from the origin (according to the metric) form a rectangle of width 1 and height \code{asp}. } \value{ A pixel image (object of class \code{"im"}). } \author{ \adrian } \seealso{ \code{\link{distmap}} } \examples{ V <- letterR Frame(V) <- grow.rectangle(Frame(V), 0.5) plot(rectdistmap(V)) } \keyword{spatial} \keyword{math} spatstat.geom/man/dirichletWeights.Rd0000644000176200001440000000356414611065346017425 0ustar liggesusers\name{dirichletWeights} \alias{dirichletWeights} \title{Compute Quadrature Weights Based on Dirichlet Tessellation} \description{ Computes quadrature weights for a given set of points, using the areas of tiles in the Dirichlet tessellation. } \usage{ dirichletWeights(X, window=NULL, exact=TRUE, \dots) } \arguments{ \item{X}{Data defining a point pattern.} \item{window}{Default window for the point pattern} \item{exact}{Logical value. If \code{TRUE}, compute exact areas using the package \code{deldir}. If \code{FALSE}, compute approximate areas using a pixel raster. } \item{\dots}{ Ignored. } } \value{ Vector of nonnegative weights for each point in \code{X}. } \details{ This function computes a set of quadrature weights for a given pattern of points (typically comprising both ``data'' and `dummy'' points). See \code{\link{quad.object}} for an explanation of quadrature weights and quadrature schemes. The weights are computed using the Dirichlet tessellation. First \code{X} and (optionally) \code{window} are converted into a point pattern object. Then the Dirichlet tessellation of the points of \code{X} is computed. The weight attached to a point of \code{X} is the area of its Dirichlet tile (inside the window \code{Window(X)}). If \code{exact=TRUE} the Dirichlet tessellation is computed exactly by the Lee-Schachter algorithm using the package \code{deldir}. Otherwise a pixel raster approximation is constructed and the areas are approximations to the true weights. In all cases the sum of the weights is equal to the area of the window. } \seealso{ \code{\link{quad.object}}, \code{\link{gridweights}} } \examples{ Q <- quadscheme(runifrect(10)) X <- as.ppp(Q) # data and dummy points together w <- dirichletWeights(X, exact=FALSE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{utilities} spatstat.geom/man/print.quad.Rd0000644000176200001440000000145214611065350016175 0ustar liggesusers\name{print.quad} \alias{print.quad} \title{Print a Quadrature Scheme} \description{ \code{print} method for a quadrature scheme. } \usage{ \method{print}{quad}(x,\dots) } \arguments{ \item{x}{ A quadrature scheme object, typically obtained from \code{\link{quadscheme}}. An object of class \code{"quad"}. } \item{\dots}{Ignored.} } \value{ none. } \details{ This is the \code{print} method for the class \code{"quad"}. It prints simple information about the quadrature scheme. See \code{\link{quad.object}} for details of the class \code{"quad"}. } \seealso{ \code{\link{quadscheme}}, \code{\link{quad.object}}, \code{\link{plot.quad}}, \code{\link{summary.quad}} } \examples{ Q <- quadscheme(cells) Q } \author{\adrian and \rolf } \keyword{spatial} \keyword{print} spatstat.geom/man/inside.boxx.Rd0000644000176200001440000000441014611065346016344 0ustar liggesusers\name{inside.boxx} \alias{inside.boxx} \title{Test Whether Points Are Inside A Multidimensional Box} \description{ Test whether points lie inside or outside a given multidimensional box. } \usage{ inside.boxx(\dots, w) } \arguments{ \item{\dots}{ Coordinates of points to be tested. One vector for each dimension (all of same length). (Alternatively, a single point pattern object of class \code{"\link{ppx}"} or its coordinates as a \code{matrix}, \code{data.frame}, or \code{"\link{hyperframe}"}) } \item{w}{A window. This should be an object of class \code{\link{boxx}}, or can be given in any format acceptable to \code{\link{as.boxx}()}. } } \value{ Logical vector whose \code{i}th entry is \code{TRUE} if the corresponding point is inside \code{w}. } \details{ This function tests whether each of the provided points lies inside or outside the window \code{w} and returns \code{TRUE} if it is inside. The boundary of the window is treated as being inside. Normally each argument provided (except \code{w}) must be numeric vectors of equal length (length zero is allowed) containing the coordinates of points. Alternatively a single point pattern (object of class \code{"ppx"}) can be given; then the coordinates of the point pattern are extracted. A single \code{matrix}, \code{data.frame}, or \code{"\link{hyperframe}"}) with the coordinates is also accepted. } \seealso{ \code{\link{boxx}}, \code{\link{as.boxx}} } \examples{ # 3D box with side [0,2] w <- boxx(c(0,2), c(0,2), c(0,2)) # Random points in box with side [-1,3] x <- runif(30, min=-1, max=3) y <- runif(30, min=-1, max=3) z <- runif(30, min=-1, max=3) # Points falling in smaller box ok <- inside.boxx(x, y, z, w=w) # Same using a point pattern as argument: X <- ppx(data = cbind(x, y, z), domain = boxx(c(0,3), c(0,3), c(0,3))) ok2 <- inside.boxx(X, w=w) # Same using the coordinates given as data.frame/matrix/hyperframe coords_mat <- cbind(x,y,z) ok_mat <- inside.boxx(coords_mat, w=w) coords_df <- data.frame(x,y,z) ok_df <- inside.boxx(coords_mat, w=w) coords_hyper <- hyperframe(x,y,z) ok_hyper <- inside.boxx(coords_mat, w=w) } \author{ \adrian \rolf and \ege } \keyword{spatial} \keyword{math} spatstat.geom/man/anyNA.im.Rd0000644000176200001440000000167314611065345015533 0ustar liggesusers\name{anyNA.im} \alias{anyNA.im} \title{ Check Whether Image Contains NA Values } \description{ Checks whether any pixel values in a pixel image are \code{NA} (meaning that the pixel lies outside the domain of definition of the image). } \usage{ \method{anyNA}{im}(x, recursive = FALSE) } \arguments{ \item{x}{ A pixel image (object of class \code{"im"}). } \item{recursive}{ Ignored. } } \details{ The function \code{\link{anyNA}} is generic: \code{anyNA(x)} is a faster alternative to \code{any(is.na(x))}. This function \code{anyNA.im} is a method for the generic \code{anyNA} defined for pixel images. It returns the value \code{TRUE} if any of the pixel values in \code{x} are \code{NA}, and and otherwise returns \code{FALSE}. } \value{ A single logical value. } \author{ \spatstatAuthors. } \seealso{ \code{\link{im.object}} } \examples{ anyNA(as.im(letterR)) } \keyword{spatial} \keyword{methods} spatstat.geom/man/rescale.owin.Rd0000644000176200001440000000361114611065350016500 0ustar liggesusers\name{rescale.owin} \alias{rescale.owin} \title{Convert Window to Another Unit of Length} \description{ Converts a window to another unit of length. } \usage{ \method{rescale}{owin}(X, s, unitname) } \arguments{ \item{X}{Window (object of class \code{"owin"}).} \item{s}{Conversion factor: the new units are \code{s} times the old units.} \item{unitname}{ Optional. New name for the unit of length. See \code{\link{unitname}}. } } \value{ Another window object (of class \code{"owin"}) representing the same window, but expressed in the new units. } \details{ This is a method for the generic function \code{\link{rescale}}. The spatial coordinates in the window \code{X} (and its window) will be re-expressed in terms of a new unit of length that is \code{s} times the current unit of length given in \code{X}. (Thus, the coordinate values are \emph{divided} by \code{s}, while the unit value is multiplied by \code{s}). The result is a window representing the \emph{same} region of space, but re-expressed in a different unit. If \code{s} is missing, then the coordinates will be re-expressed in \sQuote{native} units; for example if the current unit is equal to 0.1 metres, then the coordinates will be re-expressed in metres. } \section{Note}{ The result of this operation is equivalent to the original window. If you want to actually change the coordinates by a linear transformation, producing a window that is larger or smaller than the original one, use \code{\link{affine}}. } \seealso{ \code{\link{unitname}}, \code{\link{rescale}}, \code{\link{rescale.owin}}, \code{\link{affine}}, \code{\link{rotate}}, \code{\link{shift}} } \examples{ W <- Window(swedishpines) W # coordinates are in decimetres (0.1 metre) # convert to metres: rescale(W, 10) # or equivalently rescale(W) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/clickppp.Rd0000644000176200001440000000542414611065345015724 0ustar liggesusers\name{clickppp} \alias{clickppp} \title{Interactively Add Points} \description{ Allows the user to create a point pattern by point-and-click in the display. } \usage{ clickppp(n=NULL, win=square(1), types=NULL, \dots, add=FALSE, main=NULL, hook=NULL) } \arguments{ \item{n}{ Number of points to be added (if this is predetermined). } \item{win}{ Window in which to create the point pattern. An object of class \code{"owin"}. } \item{types}{ Vector of types, when creating a multitype point pattern. } \item{\dots}{ Optional extra arguments to be passed to \code{\link[graphics]{locator}} to control the display. } \item{add}{ Logical value indicating whether to create a new plot (\code{add=FALSE}) or draw over the existing plot (\code{add=TRUE}). } \item{main}{ Main heading for plot. } \item{hook}{For internal use only. Do not use this argument.} } \value{ A point pattern (object of class \code{"ppp"}). } \details{ This function allows the user to create a point pattern by interactively clicking on the screen display. First the window \code{win} is plotted on the current screen device. Then the user is prompted to point the mouse at any desired locations and click the left mouse button to add each point. Interactive input stops after \code{n} clicks (if \code{n} was given) or when the middle mouse button is pressed. The return value is a point pattern containing the locations of all the clicked points inside the original window \code{win}, provided that all of the clicked locations were inside this window. Otherwise, the window is expanded to a box large enough to contain all the points (as well as containing the original window). If the argument \code{types} is given, then a multitype point pattern will be created. The user is prompted to input the locations of points of type \code{type[i]}, for each successive index \code{i}. (If the argument \code{n} was given, there will be \code{n} points of \emph{each} type.) The return value is a multitype point pattern. This function uses the \R{} command \code{\link[graphics]{locator}} to input the mouse clicks. It only works on screen devices such as \sQuote{X11}, \sQuote{windows} and \sQuote{quartz}. Arguments that can be passed to \code{\link[graphics]{locator}} through \code{\dots} include \code{pch} (plotting character), \code{cex} (character expansion factor) and \code{col} (colour). See \code{\link[graphics]{locator}} and \code{\link[graphics]{par}}. } \seealso{ \code{\link{identify.ppp}}, \code{\link[graphics]{locator}}, \code{\link{clickpoly}}, \code{\link{clickbox}}, \code{\link{clickdist}} } \author{Original by Dominic Schuhmacher. Adapted by \adrian and \rolf. } \keyword{spatial} \keyword{iplot} spatstat.geom/man/markstat.Rd0000644000176200001440000000706614650323103015741 0ustar liggesusers\name{markstat} \alias{markstat} \title{Summarise Marks in Every Neighbourhood in a Point Pattern} \description{ Visit each point in a point pattern, find the neighbouring points, and summarise their marks } \usage{ markstat(X, fun, N=NULL, R=NULL, \dots) } \arguments{ \item{X}{ A marked point pattern. An object of class \code{"ppp"}. } \item{fun}{ Function to be applied to the vector of marks. } \item{N}{ Integer. If this argument is present, the neighbourhood of a point of \code{X} is defined to consist of the \code{N} points of \code{X} which are closest to it. } \item{R}{ Nonnegative numeric value. If this argument is present, the neighbourhood of a point of \code{X} is defined to consist of all points of \code{X} which lie within a distance \code{R} of it. } \item{\dots}{ extra arguments passed to the function \code{fun}. They must be given in the form \code{name=value}. } } \value{ Similar to the result of \code{\link{apply}}. if each call to \code{fun} returns a single numeric value, the result is a vector of dimension \code{npoints(X)}, the number of points in \code{X}. If each call to \code{fun} returns a vector of the same length \code{m}, then the result is a matrix of dimensions \code{c(m,n)}; note the transposition of the indices, as usual for the family of \code{apply} functions. If the calls to \code{fun} return vectors of different lengths, the result is a list of length \code{npoints(X)}. } \details{ This algorithm visits each point in the point pattern \code{X}, determines which points of \code{X} are ``neighbours'' of the current point, extracts the marks of these neighbouring points, applies the function \code{fun} to the marks, and collects the value or values returned by \code{fun}. The definition of ``neighbours'' depends on the arguments \code{N} and \code{R}, exactly one of which must be given. If \code{N} is given, then the neighbours of the current point are the \code{N} points of \code{X} which are closest to the current point (including the current point itself). If \code{R} is given, then the neighbourhood of the current point consists of all points of \code{X} which lie closer than a distance \code{R} from the current point. Each point of \code{X} is visited; the neighbourhood of the current point is determined; the marks of these points are extracted as a vector \code{v}; then the function \code{fun} is called as: \code{fun(v, \dots)} where \code{\dots} are the arguments passed from the call to \code{markstat}. The results of each call to \code{fun} are collected and returned according to the usual rules for \code{\link{apply}} and its relatives. See the section on \bold{Value}. This function is just a convenient wrapper for a common use of the function \code{\link[spatstat.geom]{applynbd}}. For more complex tasks, use \code{\link[spatstat.geom]{applynbd}}. To simply tabulate the marks in every \code{R}-neighbourhood, use \code{\link[spatstat.explore]{marktable}}. } \seealso{ \code{\link[spatstat.geom]{applynbd}}, \code{\link[spatstat.explore]{marktable}}, \code{\link[spatstat.geom]{ppp.object}}, \code{\link{apply}} } \examples{ trees <- longleaf \testonly{ trees <- trees[seq(1, npoints(trees), by=6)] } # average diameter of 5 closest neighbours of each tree md <- markstat(trees, mean, N=5) # range of diameters of trees within 10 metre radius rd <- markstat(trees, range, R=10) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{programming} spatstat.geom/man/square.Rd0000644000176200001440000000266614611065350015420 0ustar liggesusers\name{square} \alias{square} \alias{unit.square} \title{Square Window} \description{ Creates a square window } \usage{ square(r=1, unitname=NULL) unit.square() } \arguments{ \item{r}{Numeric. The side length of the square, or a vector giving the minimum and maximum coordinate values. } \item{unitname}{ Optional. Name of unit of length. Either a single character string, or a vector of two character strings giving the singular and plural forms, respectively. } } \value{ An object of class \code{"owin"} (see \code{\link{owin.object}}) specifying a window. } \details{ If \code{r} is a number, \code{square(r)} is a shortcut for creating a window object representing the square \eqn{[0,r] \times [0,r]}{[0,r] * [0,r]}. It is equivalent to the command \code{owin(c(0,r),c(0,r))}. If \code{r} is a vector of length 2, then \code{square(r)} creates the square with \code{x} and \code{y} coordinates ranging from \code{r[1]} to \code{r[2]}. \code{unit.square} creates the unit square \eqn{[0,1] \times [0,1]}{[0,1] * [0,1]}. It is equivalent to \code{square(1)} or \code{square()} or \code{owin(c(0,1),c(0,1))}. These commands are included for convenience, and to improve the readability of some code. } \seealso{ \code{\link{owin.object}}, \code{\link{owin}} } \examples{ W <- square(10) W <- square(c(-1,1)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/fourierbasis.Rd0000644000176200001440000000424714611065346016617 0ustar liggesusers\name{fourierbasis} \alias{fourierbasis} \alias{fourierbasisraw} \title{Fourier Basis Functions} \description{Evaluates the Fourier basis functions on a \eqn{d}-dimensional box with \eqn{d}-dimensional frequencies \eqn{k_i} at the \eqn{d}-dimensional coordinates \eqn{x_j}. } \usage{ fourierbasis(x, k, win = boxx(rep(list(0:1), ncol(k)))) fourierbasisraw(x, k, boxlengths) } \arguments{ \item{x}{ Coordinates. A \code{data.frame} or matrix with \eqn{n} rows and \eqn{d} columns giving the \eqn{d}-dimensional coordinates. } \item{k}{Frequencies. A \code{data.frame} or matrix with \eqn{m} rows and \eqn{d} columns giving the frequencies of the Fourier-functions. } \item{win}{ window (of class \code{"owin"}, \code{"box3"} or \code{"boxx"}) giving the \eqn{d}-dimensional box domain of the Fourier functions. } \item{boxlengths}{ numeric giving the side lengths of the box domain of the Fourier functions. } } \details{ The result is an \eqn{m} by \eqn{n} matrix where the \eqn{(i,j)}'th entry is the \eqn{d}-dimensional Fourier basis function with frequency \eqn{k_i} evaluated at the point \eqn{x_j}, i.e., \deqn{ \frac{1}{\sqrt{|W|}} \exp(2\pi i \sum{l=1}^d k_{i,l} x_{j,l}/L_l) }{ 1/sqrt(|W|) * exp(2*pi*i*(k_{i,1}*x_{j,1}/L_1 + ... + k_{i,d}*x_{j,d}/L_d)) } where \eqn{L_l}, \eqn{l=1,...,d} are the box side lengths and \eqn{|W|} is the volume of the domain (window/box). Note that the algorithm does not check whether the coordinates given in \code{x} are contained in the given box. Actually the box is only used to determine the side lengths and volume of the domain for normalization. The stripped down faster version \code{fourierbasisraw} doesn't do checking or conversion of arguments and requires \code{x} and \code{k} to be matrices. } \value{An \code{m} by \code{n} matrix of complex values.} \author{ \adrian \rolf and \ege } \examples{ ## 27 rows of three dimensional Fourier frequencies: k <- expand.grid(-1:1,-1:1, -1:1) ## Two random points in the three dimensional unit box: x <- rbind(runif(3),runif(3)) ## 27 by 2 resulting matrix: v <- fourierbasis(x, k) head(v) } spatstat.geom/man/rjitter.Rd0000644000176200001440000001002414667453120015575 0ustar liggesusers\name{rjitter} \alias{rjitter} \alias{rjitter.ppp} \title{Random Perturbation of a Point Pattern} \description{ Applies independent random displacements to each point in a point pattern. } \usage{ rjitter(X, \dots) \method{rjitter}{ppp}(X, radius, retry=TRUE, giveup = 10000, trim=FALSE, \dots, nsim=1, drop=TRUE, adjust=1) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"}). } \item{radius}{ Scale of perturbations. A positive numerical value. The displacement vectors will be uniformly distributed in a circle of this radius. There is a sensible default. Alternatively, \code{radius} may be a numeric vector of length equal to the number of points in \code{X}, giving a different displacement radius for each data point. } \item{retry}{ What to do when a perturbed point lies outside the window of the original point pattern. If \code{retry=FALSE}, the point will be lost; if \code{retry=TRUE}, the algorithm will try again. } \item{giveup}{ Maximum number of unsuccessful attempts. } \item{trim}{ Logical value. If \code{TRUE}, the displacement radius for each data point will be constrained to be less than or equal to the distance from the data point to the window boundary. This ensures that all displaced points will fall inside the window. } \item{\dots}{Ignored.} \item{nsim}{Number of simulated realisations to be generated.} \item{drop}{ Logical. If \code{nsim=1} and \code{drop=TRUE} (the default), the result will be a point pattern, rather than a list containing a point pattern. } \item{adjust}{ Adjustment factor applied to the radius. A numeric value or numeric vector. } } \value{ The result of \code{rjitter.ppp} is a point pattern (an object of class \code{"ppp"}) or a list of point patterns. Each point pattern has attributes \code{"radius"} and (if \code{retry=TRUE}) \code{"tries"}. } \details{ The function \code{rjitter} is generic, with methods for point patterns (described here) and for some other types of geometrical objects. Each of the points in the point pattern \code{X} is subjected to an independent random displacement. The displacement vectors are uniformly distributed in a circle of radius \code{radius}. If a displaced point lies outside the window, then if \code{retry=FALSE} the point will be lost. However if \code{retry=TRUE}, the algorithm will try again: each time a perturbed point lies outside the window, the algorithm will reject the perturbed point and generate another proposed perturbation of the original point, until one lies inside the window, or until \code{giveup} unsuccessful attempts have been made. In the latter case, any unresolved points will be included, without any perturbation. The return value will always be a point pattern with the same number of points as \code{X}. If \code{trim=TRUE}, then the displacement radius for each data point will be constrained to be less than or equal to the distance from the data point to the window boundary. This ensures that the randomly displaced points will always fall inside the window; no displaced points will be lost and no retrying will be required. However, it implies that a point lying exactly on the boundary will never be perturbed. If \code{adjust} is given, the jittering radius will be multiplied by \code{adjust}. This allows the user to specify that the radius should be a multiple of the default radius. The resulting point pattern has an attribute \code{"radius"} giving the value of \code{radius} used. If \code{retry=TRUE}, the resulting point pattern also has an attribute \code{"tries"} reporting the maximum number of trials needed to ensure that all jittered points were inside the window. } \examples{ X <- rsyst(owin(), 10, 10) Y <- rjitter(X, 0.02) plot(Y) Z <- rjitter(X) U <- rjitter(X, 0.025, trim=TRUE) } \author{ \spatstatAuthors. } \seealso{ \code{\link{rexplode}} } \keyword{spatial} \keyword{datagen} \keyword{manip} spatstat.geom/man/convexify.Rd0000644000176200001440000000334214611065345016126 0ustar liggesusers\name{convexify} \alias{convexify} \title{ Weil's Convexifying Operation } \description{ Converts the window \code{W} into a convex set by rearranging the edges, preserving spatial orientation of each edge. } \usage{ convexify(W, eps) } \arguments{ \item{W}{ A window (object of class \code{"owin"}). } \item{eps}{ Optional. Minimum edge length of polygonal approximation, if \code{W} is not a polygon. } } \details{ Weil (1995) defined a convexification operation for windows \eqn{W} that belong to the convex ring (that is, for any \eqn{W} which is a finite union of convex sets). Note that this is \bold{not} the same as the convex hull. The convexified set \eqn{f(W)} has the same total boundary length as \eqn{W} and the same distribution of orientations of the boundary. If \eqn{W} is a polygonal set, then the convexification \eqn{f(W)} is obtained by rearranging all the edges of \eqn{W} in order of their spatial orientation. The argument \code{W} must be a window. If it is not already a polygonal window, it is first converted to one, using \code{\link{simplify.owin}}. The edges are sorted in increasing order of angular orientation and reassembled into a convex polygon. } \value{ A window (object of class \code{"owin"}). } \references{ Weil, W. (1995) The estimation of mean particle shape and mean particle number in overlapping particle systems in the plane. \emph{Advances in Applied Probability} \bold{27}, 102--119. } \author{ \adrian \rolf and \ege } \seealso{ \code{\link{convexhull}} for the convex hull of a window. } \examples{ opa <- par(mfrow=c(1,2)) plot(letterR) plot(convexify(letterR)) par(opa) } \keyword{spatial} \keyword{utilities} spatstat.geom/man/rotate.infline.Rd0000644000176200001440000000361614611065350017035 0ustar liggesusers\name{rotate.infline} \alias{rotate.infline} \alias{shift.infline} \alias{reflect.infline} \alias{flipxy.infline} \title{ Rotate or Shift Infinite Lines } \description{ Given the coordinates of one or more infinite straight lines in the plane, apply a rotation or shift. } \usage{ \method{rotate}{infline}(X, angle = pi/2, \dots) \method{shift}{infline}(X, vec = c(0,0), \dots) \method{reflect}{infline}(X) \method{flipxy}{infline}(X) } \arguments{ \item{X}{ Object of class \code{"infline"} representing one or more infinite straight lines in the plane. } \item{angle}{ Angle of rotation, in radians. } \item{vec}{ Translation (shift) vector: a numeric vector of length 2, or a \code{list(x,y)}, or a point pattern containing one point. } \item{\dots}{ Ignored. } } \details{ These functions are methods for the generic \code{\link{shift}}, \code{\link{rotate}}, \code{\link{reflect}} and \code{\link{flipxy}} for the class \code{"infline"}. An object of class \code{"infline"} represents one or more infinite lines in the plane. } \value{ Another \code{"infline"} object representing the result of the transformation. } \author{ \adrian. } \seealso{ \code{\link{infline}} } \examples{ L <- infline(v=0.5) plot(square(c(-1,1)), main="rotate lines", type="n") points(0, 0, pch=3) plot(L, col="green") plot(rotate(L, pi/12), col="red") plot(rotate(L, pi/6), col="red") plot(rotate(L, pi/4), col="red") L <- infline(p=c(0.4, 0.9), theta=pi* c(0.2, 0.6)) plot(square(c(-1,1)), main="shift lines", type="n") L <- infline(p=c(0.7, 0.8), theta=pi* c(0.2, 0.6)) plot(L, col="green") plot(shift(L, c(-0.5, -0.4)), col="red") plot(square(c(-1,1)), main="reflect lines", type="n") points(0, 0, pch=3) L <- infline(p=c(0.7, 0.8), theta=pi* c(0.2, 0.6)) plot(L, col="green") plot(reflect(L), col="red") } \keyword{spatial} \keyword{manip} spatstat.geom/man/border.Rd0000644000176200001440000000340414611065345015370 0ustar liggesusers\name{border} \alias{border} \title{Border Region of a Window} \description{ Computes the border region of a window, that is, the region lying within a specified distance of the boundary of a window. } \usage{ border(w, r, outside=FALSE, ...) } \arguments{ \item{w}{A window (object of class \code{"owin"}) or something acceptable to \code{\link{as.owin}}. } \item{r}{Numerical value.} \item{outside}{Logical value determining whether to compute the border outside or inside \code{w}.} \item{\dots}{ Optional arguments passed to \code{\link{erosion}} (if \code{outside=FALSE}) or to \code{\link{dilation}} (if \code{outside=TRUE}). } } \value{ A window (object of class \code{"owin"}). } \details{ By default (if \code{outside=FALSE}), the border region is the subset of \code{w} lying within a distance \code{r} of the boundary of \code{w}. It is computed by eroding \code{w} by the distance \code{r} (using \code{\link{erosion}}) and subtracting this eroded window from the original window \code{w}. If \code{outside=TRUE}, the border region is the set of locations outside \code{w} lying within a distance \code{r} of \code{w}. It is computed by dilating \code{w} by the distance \code{r} (using \code{\link{dilation}}) and subtracting the original window \code{w} from the dilated window. } \author{\adrian and \rolf } \seealso{ \code{\link{erosion}}, \code{\link{dilation}} } \examples{ # rectangle u <- unit.square() border(u, 0.1) border(u, 0.1, outside=TRUE) # polygon \testonly{opa <- spatstat.options(npixel=32)} plot(letterR) plot(border(letterR, 0.1), add=TRUE) plot(border(letterR, 0.1, outside=TRUE), add=TRUE) \testonly{spatstat.options(opa)} } \keyword{spatial} \keyword{math} spatstat.geom/man/intersect.tess.Rd0000644000176200001440000000510514643111575017072 0ustar liggesusers\name{intersect.tess} \alias{intersect.tess} \title{Intersection of Two Tessellations} \description{ Yields the intersection of two tessellations, or the intersection of a tessellation with a window. } \usage{ intersect.tess(X, Y, \dots, keepempty=FALSE, keepmarks=FALSE, sep="x") } \arguments{ \item{X,Y}{Two tessellations (objects of class \code{"tess"}), or windows (objects of class \code{"tess"}), or other data that can be converted to tessellations by \code{\link{as.tess}}. } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} to control the discretisation, if required. } \item{keepempty}{ Logical value specifying whether empty intersections between tiles should be retained (\code{keepempty=TRUE}) or deleted (\code{keepempty=FALSE}, the default). } \item{keepmarks}{ Logical value. If \code{TRUE}, the marks attached to the tiles of \code{X} and \code{Y} will be retained as marks of the intersection tiles. } \item{sep}{ Character string used to separate the names of tiles from \code{X} and from \code{Y}, when forming the name of the tiles of the intersection. } } \value{ A tessellation (object of class \code{"tess"}). } \details{ A tessellation is a collection of disjoint spatial regions (called \emph{tiles}) that fit together to form a larger spatial region. See \code{\link{tess}}. If \code{X} and \code{Y} are not tessellations, they are first converted into tessellations by \code{\link{as.tess}}. The function \code{intersect.tess} then computes the intersection between the two tessellations. This is another tessellation, each of whose tiles is the intersection of a tile from \code{X} and a tile from \code{Y}. One possible use of this function is to slice a window \code{W} into subwindows determined by a tessellation. See the Examples. } \author{ \adrian and \rolf } \seealso{ \code{\link{tess}}, \code{\link{as.tess}}, \code{\link{intersect.owin}} } \examples{ opa <- par(mfrow=c(1,3)) # polygon plot(letterR) # tessellation of rectangles X <- tess(xgrid=seq(2, 4, length=10), ygrid=seq(0, 3.5, length=8)) plot(X) plot(intersect.tess(X, letterR)) A <- runifrect(10) B <- runifrect(10) plot(DA <- dirichlet(A)) plot(DB <- dirichlet(B)) plot(intersect.tess(DA, DB)) par(opa) marks(DA) <- 1:10 marks(DB) <- 1:10 plot(Z <- intersect.tess(DA,DB, keepmarks=TRUE)) mZ <- marks(Z) tZ <- tiles(Z) for(i in which(mZ[,1] == 3)) plot(tZ[[i]], add=TRUE, col="pink") } \keyword{spatial} \keyword{math} \concept{Tessellation} spatstat.geom/man/yardstick.Rd0000644000176200001440000000516214611065351016110 0ustar liggesusers\name{yardstick} \alias{textstring} \alias{onearrow} \alias{yardstick} \title{ Text, Arrow or Scale Bar in a Diagram } \description{ Create spatial objects that represent a text string, an arrow, or a yardstick (scale bar). } \usage{ textstring(x, y, txt = NULL, \dots) onearrow(x0, y0, x1, y1, txt = NULL, \dots) yardstick(x0, y0, x1, y1, txt = NULL, \dots) } \arguments{ \item{x,y}{ Coordinates where the text should be placed. } \item{x0,y0,x1,y1}{ Spatial coordinates of both ends of the arrow or yardstick. Alternatively \code{x0} can be a point pattern (class \code{"ppp"}) containing exactly two points, or a line segment pattern (class \code{"psp"}) consisting of exactly one line segment. } \item{txt}{ The text to be displayed beside the line segment. Either a character string or an expression. } \item{\dots}{ Additional named arguments for plotting the object. } } \details{ These commands create objects that represent components of a diagram: \itemize{ \item \code{textstring} creates an object that represents a string of text at a particular spatial location. \item \code{onearrow} creates an object that represents an arrow between two locations. \item \code{yardstick} creates an object that represents a scale bar: a line segment indicating the scale of the plot. } To display the relevant object, it should be plotted, using \code{plot}. See the help files for the plot methods \code{\link{plot.textstring}}, \code{\link{plot.onearrow}} and \code{\link{plot.yardstick}}. These objects are designed to be included as components in a \code{\link{layered}} object or a \code{\link{solist}}. This makes it possible to build up a diagram consisting of many spatial objects, and to annotate the diagram with arrows, text and so on, so that ultimately the entire diagram is plotted using \code{plot}. } \value{ An object of class \code{"diagramobj"} which also belongs to one of the special classes \code{"textstring"}, \code{"onearrow"} or \code{"yardstick"}. There are methods for \code{plot}, \code{print}, \code{"["} and \code{\link{shift}}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{plot.textstring}}, \code{\link{plot.onearrow}}, \code{\link{plot.yardstick}}. } \examples{ X <- rescale(swedishpines) plot(X, pch=16, main="") yd <- yardstick(0,0,1,1, "diagonal") yy <- yardstick(X[1:2]) ys <- yardstick(as.psp(list(xmid=4, ymid=0.5, length=1, angle=0), window=Window(X)), txt="1 m") ys plot(ys, angle=90) scalardilate(ys, 2) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/Extract.owin.Rd0000644000176200001440000000217614611065346016506 0ustar liggesusers\name{Extract.owin} \alias{[.owin} \title{Extract Subset of Window} \description{ Extract a subset of a window. } \usage{ \method{[}{owin}(x, i, \dots) } \arguments{ \item{x}{ A spatial window (object of class \code{"owin"}). } \item{i}{ Object defining the subregion. Either a spatial window, or a pixel image with logical values. } \item{\dots}{Ignored.} } \value{ Another spatial window (object of class \code{"owin"}). } \details{ This function computes the intersection between the window \code{x} and the domain specified by \code{i}, using \code{\link{intersect.owin}}. This function is a method for the subset operator \code{"["} for spatial windows (objects of class \code{"owin"}). It is provided mainly for completeness. The index \code{i} may be either a window, or a pixel image with logical values (the \code{TRUE} values of the image specify the spatial domain). } \seealso{ \code{\link{intersect.owin}} } \examples{ W <- owin(c(2.5, 3.2), c(1.4, 2.9)) plot(letterR) plot(letterR[W], add=TRUE, col="red") } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/affine.Rd0000644000176200001440000000231214611065345015340 0ustar liggesusers\name{affine} \alias{affine} \title{Apply Affine Transformation} \description{ Applies any affine transformation of the plane (linear transformation plus vector shift) to a plane geometrical object, such as a point pattern or a window. } \usage{ affine(X, \dots) } \arguments{ \item{X}{Any suitable dataset representing a two-dimensional object, such as a point pattern (object of class \code{"ppp"}), a line segment pattern (object of class \code{"psp"}), a window (object of class \code{"owin"}) or a pixel image (object of class \code{"im"}). } \item{\dots}{Arguments determining the affine transformation.} } \value{ Another object of the same type, representing the result of applying the affine transformation. } \details{ This is generic. Methods are provided for point patterns (\code{\link{affine.ppp}}) and windows (\code{\link{affine.owin}}). } \seealso{ \code{\link{affine.ppp}}, \code{\link{affine.psp}}, \code{\link{affine.owin}}, \code{\link{affine.im}}, \code{\link{flipxy}}, \code{\link{reflect}}, \code{\link{rotate}}, \code{\link{shift}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} \concept{Geometrical transformations} spatstat.geom/man/erosion.Rd0000644000176200001440000000632414643111575015577 0ustar liggesusers\name{erosion} \alias{erosion} \alias{erosion.owin} \alias{erosion.ppp} \alias{erosion.psp} \title{Morphological Erosion by a Disc} \description{ Perform morphological erosion of a window, a line segment pattern or a point pattern by a disc. } \usage{ erosion(w, r, \dots) \method{erosion}{owin}(w, r, shrink.frame=TRUE, \dots, strict=FALSE, polygonal=NULL) \method{erosion}{ppp}(w, r,\dots) \method{erosion}{psp}(w, r,\dots) } \arguments{ \item{w}{ A window (object of class \code{"owin"} or a line segment pattern (object of class \code{"psp"}) or a point pattern (object of class \code{"ppp"}). } \item{r}{positive number: the radius of erosion.} \item{shrink.frame}{logical: if \code{TRUE}, erode the bounding rectangle as well.} \item{\dots}{extra arguments to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution, if pixel approximation is used.} \item{strict}{Logical flag determining the fate of boundary pixels, if pixel approximation is used. See details.} \item{polygonal}{ Logical flag indicating whether to compute a polygonal approximation to the erosion (\code{polygonal=TRUE}) or a pixel grid approximation (\code{polygonal=FALSE}). } } \value{ If \code{r > 0}, an object of class \code{"owin"} representing the eroded region (or \code{NULL} if this region is empty). If \code{r=0}, the result is identical to \code{w}. } \details{ The morphological erosion of a set \eqn{W} by a distance \eqn{r > 0} is the subset consisting of all points \eqn{x \in W}{x in W} such that the distance from \eqn{x} to the boundary of \eqn{W} is greater than or equal to \eqn{r}. In other words it is the result of trimming a margin of width \eqn{r} off the set \eqn{W}. If \code{polygonal=TRUE} then a polygonal approximation to the erosion is computed. If \code{polygonal=FALSE} then a pixel approximation to the erosion is computed from the distance map of \code{w}. The arguments \code{"\dots"} are passed to \code{\link[spatstat.geom]{as.mask}} to control the pixel resolution. The erosion consists of all pixels whose distance from the boundary of \code{w} is strictly greater than \code{r} (if \code{strict=TRUE}) or is greater than or equal to \code{r} (if \code{strict=FALSE}). When \code{w} is a window, the default (when \code{polygonal=NULL}) is to compute a polygonal approximation if \code{w} is a rectangle or polygonal window, and to compute a pixel approximation if \code{w} is a window of type \code{"mask"}. If \code{shrink.frame} is false, the resulting window is given the same outer, bounding rectangle as the original window \code{w}. If \code{shrink.frame} is true, the original bounding rectangle is also eroded by the same distance \code{r}. To simply compute the area of the eroded window, use \code{\link{eroded.areas}}. } \seealso{ \code{\link{dilation}} for the opposite operation. \code{\link{erosionAny}} for morphological erosion using any shape. \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{eroded.areas}} } \examples{ plot(letterR, main="erosion(letterR, 0.2)") plot(erosion(letterR, 0.2), add=TRUE, col="red") } \author{ \spatstatAuthors } \keyword{spatial} \keyword{math} spatstat.geom/man/methods.box3.Rd0000644000176200001440000000257514611065347016442 0ustar liggesusers\name{methods.box3} \Rdversion{1.1} \alias{methods.box3} %DoNotExport \alias{print.box3} \alias{unitname.box3} \alias{unitname<-.box3} \title{ Methods for Three-Dimensional Box } \description{ Methods for class \code{"box3"}. } \usage{ \method{print}{box3}(x, ...) \method{unitname}{box3}(x) \method{unitname}{box3}(x) <- value } \arguments{ \item{x}{ Object of class \code{"box3"} representing a three-dimensional box. } \item{\dots}{ Other arguments passed to \code{print.default}. } \item{value}{ Name of the unit of length. See \code{\link{unitname}}. } } \details{ These are methods for the generic functions \code{\link{print}} and \code{\link{unitname}} for the class \code{"box3"} of three-dimensional boxes. The \code{print} method prints a description of the box, while the \code{unitname} method extracts the name of the unit of length in which the box coordinates are expressed. } \value{ For \code{print.box3} the value is \code{NULL}. For \code{unitname.box3} an object of class \code{"units"}. } \author{\adrian and \rolf } \seealso{ \code{\link{box3}}, \code{\link{print}}, \code{\link{unitname}} } \examples{ X <- box3(c(0,10),c(0,10),c(0,5), unitname=c("metre", "metres")) X unitname(X) # Northern European usage unitname(X) <- "meter" } \keyword{spatial} \keyword{methods} \concept{Three-dimensional} spatstat.geom/man/dirichletVertices.Rd0000644000176200001440000000403514611065346017571 0ustar liggesusers\name{dirichletVertices} \alias{dirichletVertices} \alias{dirichletEdges} \title{ Vertices and Edges of Dirichlet Tessellation } \description{ Computes the Dirichlet-Voronoi tessellation of a point pattern and extracts the vertices or edges of the tiles. } \usage{ dirichletVertices(X) dirichletEdges(X, clip=TRUE) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"}). } \item{clip}{ Logical value specifying whether to clip the tile edges to the window. See Details. } } \details{ These function compute the Dirichlet-Voronoi tessellation of \code{X} (see \code{\link{dirichlet}}) and extract the vertices or edges of the tiles of the tessellation. The Dirichlet vertices are the spatial locations which are locally farthest away from \code{X}, that is, where the distance function of \code{X} reaches a local maximum. The Dirichlet edges are the dividing lines equally distant between a pair of points of \code{X}. The Dirichlet tessellation of \code{X} is computed using \code{\link{dirichlet}}. The vertices or edges of all tiles of the tessellation are extracted. For \code{dirichletVertices}, any vertex which lies on the boundary of the window of \code{X} is deleted. The remaining vertices are returned, as a point pattern, without duplicated entries. For \code{dirichletEdges}, the edges are initially computed inside the rectangle \code{Frame(X)}. Then if \code{clip=TRUE} (the default), these edges are intersected with \code{Window(X)}, which may cause an edge to be broken into several pieces. } \value{ \code{dirichletVertices} returns a point pattern (object of class \code{"ppp"}) in the same window as \code{X}. \code{dirichletEdges} returns a line segment pattern (object of class \code{"psp"}). } \seealso{ \code{\link{dirichlet}}, \code{\link{dirichletAreas}} } \examples{ plot(dirichlet(cells)) plot(dirichletVertices(cells), add=TRUE) ed <- dirichletEdges(cells) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} \keyword{manip} spatstat.geom/man/as.psp.Rd0000644000176200001440000001467414611065345015332 0ustar liggesusers\name{as.psp} \alias{as.psp} \alias{as.psp.psp} \alias{as.psp.data.frame} \alias{as.psp.matrix} \alias{as.psp.default} \title{Convert Data To Class psp} \description{ Tries to coerce any reasonable kind of data object to a line segment pattern (an object of class \code{"psp"}) for use by the \pkg{spatstat} package. } \usage{ as.psp(x, \dots, from=NULL, to=NULL) \method{as.psp}{psp}(x, \dots, check=FALSE, fatal=TRUE) \method{as.psp}{data.frame}(x, \dots, window=NULL, marks=NULL, check=spatstat.options("checksegments"), fatal=TRUE) \method{as.psp}{matrix}(x, \dots, window=NULL, marks=NULL, check=spatstat.options("checksegments"), fatal=TRUE) \method{as.psp}{default}(x, \dots, window=NULL, marks=NULL, check=spatstat.options("checksegments"), fatal=TRUE) } \arguments{ \item{x}{Data which will be converted into a line segment pattern} \item{window}{Data which define a window for the pattern.} \item{\dots}{Ignored.} \item{marks}{(Optional) vector or data frame of marks for the pattern} \item{check}{ Logical value indicating whether to check the validity of the data, e.g. to check that the line segments lie inside the window. } \item{fatal}{Logical value. See Details.} \item{from,to}{Point patterns (object of class \code{"ppp"}) containing the first and second endpoints (respectively) of each segment. Incompatible with \code{x}. } } \value{ An object of class \code{"psp"} (see \code{\link{psp.object}}) describing the line segment pattern and its window of observation. The value \code{NULL} may also be returned; see Details. } \details{ Converts the dataset \code{x} to a line segment pattern (an object of class \code{"psp"}; see \code{\link{psp.object}} for an overview). This function is normally used to convert an existing line segment pattern dataset, stored in another format, to the \code{"psp"} format. To create a new point pattern from raw data such as \eqn{x,y} coordinates, it is normally easier to use the creator function \code{\link{psp}}. The dataset \code{x} may be: \itemize{ \item an object of class \code{"psp"} \item a data frame with at least 4 columns \item a structure (list) with elements named \code{x0, y0, x1, y1} or elements named \code{xmid, ymid, length, angle} and possibly a fifth element named \code{marks} } If \code{x} is a data frame the interpretation of its columns is as follows: \itemize{ \item If there are columns named \code{x0, y0, x1, y1} then these will be interpreted as the coordinates of the endpoints of the segments and used to form the \code{ends} component of the \code{psp} object to be returned. \item If there are columns named \code{xmid, ymid, length, angle} then these will be interpreted as the coordinates of the segment midpoints, the lengths of the segments, and the orientations of the segments in radians and used to form the \code{ends} component of the \code{psp} object to be returned. \item If there is a column named \code{marks} then this will be interpreted as the marks of the pattern provided that the argument \code{marks} of this function is \code{NULL}. If argument \code{marks} is not \code{NULL} then the value of this argument is taken to be the marks of the pattern and the column named \code{marks} is ignored (with a warning). In either case the column named marks is deleted and omitted from further consideration. \item If there is no column named \code{marks} and if the \code{marks} argument of this function is \code{NULL}, and if after interpreting 4 columns of \code{x} as determining the \code{ends} component of the \code{psp} object to be returned, there remain other columns of \code{x}, then these remaining columns will be taken to form a data frame of marks for the \code{psp} object to be returned. } If \code{x} is a structure (list) with elements named \code{x0, y0, x1, y1, marks} or \code{xmid, ymid, length, angle, marks}, then the element named \code{marks} will be interpreted as the marks of the pattern provide that the argument \code{marks} of this function is \code{NULL}. If this argument is non-\code{NULL} then it is interpreted as the marks of the pattern and the element \code{marks} of \code{x} is ignored --- with a warning. Alternatively, you may specify two point patterns \code{from} and \code{to} containing the first and second endpoints of the line segments. The argument \code{window} is converted to a window object by the function \code{\link{as.owin}}. The argument \code{fatal} indicates what to do when the data cannot be converted to a line segment pattern. If \code{fatal=TRUE}, a fatal error will be generated; if \code{fatal=FALSE}, the value \code{NULL} is returned. The function \code{as.psp} is generic, with methods for the classes \code{"psp"}, \code{"data.frame"}, \code{"matrix"} and a default method. Point pattern datasets can also be created by the function \code{\link{psp}}. } \section{Warnings}{ If only a proper subset of the names \code{x0,y0,x1,y1} or \code{xmid,ymid,length,angle} appear amongst the names of the columns of \code{x} where \code{x} is a data frame, then these special names are ignored. For example if the names of the columns were \code{xmid,ymid,length,degrees}, then these columns would be interpreted as if the represented \code{x0,y0,x1,y1} in that order. Whether it gets used or not, column named \code{marks} is \emph{always} removed from \code{x} before any attempt to form the \code{ends} component of the \code{psp} object that is returned. } \seealso{ \code{\link{psp}}, \code{\link{psp.object}}, \code{\link{as.owin}}, \code{\link{owin.object}}. See \code{\link{edges}} for extracting the edges of a polygonal window as a \code{"psp"} object. } \examples{ mat <- matrix(runif(40), ncol=4) mx <- data.frame(v1=sample(1:4,10,TRUE), v2=factor(sample(letters[1:4],10,TRUE),levels=letters[1:4])) a <- as.psp(mat, window=owin(),marks=mx) mat <- cbind(as.data.frame(mat),mx) b <- as.psp(mat, window=owin()) # a and b are identical. stuff <- list(xmid=runif(10), ymid=runif(10), length=rep(0.1, 10), angle=runif(10, 0, 2 * pi)) a <- as.psp(stuff, window=owin()) b <- as.psp(from=runifrect(10), to=runifrect(10)) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/pixellate.Rd0000644000176200001440000000316414611065347016107 0ustar liggesusers\name{pixellate} \Rdversion{1.1} \alias{pixellate} \title{ Convert Spatial Object to Pixel Image } \description{ Convert a spatial object to a pixel image by measuring the amount of stuff in each pixel. } \usage{ pixellate(x, ...) } \arguments{ \item{x}{ Spatial object to be converted. A point pattern (object of class \code{"ppp"}), a window (object of class \code{"owin"}), a line segment pattern (object of class \code{"psp"}), or some other suitable data. } \item{\dots}{ Arguments passed to methods. } } \details{ The function \code{pixellate} converts a geometrical object \code{x} into a pixel image, by measuring the \emph{amount} of \code{x} that is inside each pixel. If \code{x} is a point pattern, \code{pixellate(x)} counts the number of points of \code{x} falling in each pixel. If \code{x} is a window, \code{pixellate(x)} measures the area of intersection of each pixel with the window. The function \code{pixellate} is generic, with methods for point patterns (\code{\link{pixellate.ppp}}), windows (\code{\link{pixellate.owin}}), and line segment patterns (\code{\link{pixellate.psp}}), See the separate documentation for these methods. The related function \code{\link{as.im}} also converts \code{x} into a pixel image, but typically measures only the presence or absence of \code{x} inside each pixel. } \value{ A pixel image (object of class \code{"im"}). } \seealso{ \code{\link{pixellate.ppp}}, \code{\link{pixellate.owin}}, \code{\link{pixellate.psp}}, \code{\link{as.im}} } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/split.im.Rd0000644000176200001440000000400314611065350015642 0ustar liggesusers\name{split.im} \alias{split.im} \title{Divide Image Into Sub-images} \description{ Divides a pixel image into several sub-images according to the value of a factor, or according to the tiles of a tessellation. } \usage{ \method{split}{im}(x, f, ..., drop = FALSE) } \arguments{ \item{x}{Pixel image (object of class \code{"im"}).} \item{f}{ Splitting criterion. Either a tessellation (object of class \code{"tess"}) or a pixel image with factor values. } \item{\dots}{Ignored.} \item{drop}{Logical value determining whether each subset should be returned as a pixel images (\code{drop=FALSE}) or as a one-dimensional vector of pixel values (\code{drop=TRUE}). } } \details{ This is a method for the generic function \code{\link{split}} for the class of pixel images. The image \code{x} will be divided into subsets determined by the data \code{f}. The result is a list of these subsets. The splitting criterion may be either \itemize{ \item a tessellation (object of class \code{"tess"}). Each tile of the tessellation delineates a subset of the spatial domain. \item a pixel image (object of class \code{"im"}) with factor values. The levels of the factor determine subsets of the spatial domain. } If \code{drop=FALSE} (the default), the result is a list of pixel images, each one a subset of the pixel image \code{x}, obtained by restricting the pixel domain to one of the subsets. If \code{drop=TRUE}, then the pixel values are returned as numeric vectors. } \value{ If \code{drop=FALSE}, a list of pixel images (objects of class \code{"im"}). It is also of class \code{"solist"} so that it can be plotted immediately. If \code{drop=TRUE}, a list of numeric vectors. } \seealso{ \code{\link{by.im}}, \code{\link{tess}}, \code{\link{im}} } \examples{ W <- square(1) X <- as.im(function(x,y){sqrt(x^2+y^2)}, W) Y <- dirichlet(runifrect(12, W)) plot(split(X,Y)) } \author{\adrian and \rolf. } \keyword{spatial} \keyword{methods} \keyword{manip} spatstat.geom/man/beachcolours.Rd0000644000176200001440000000542314611065345016567 0ustar liggesusers\name{beachcolours} \alias{beachcolours} \alias{beachcolourmap} \title{ Create Colour Scheme for a Range of Numbers } \description{ Given a range of numerical values, this command creates a colour scheme that would be appropriate if the numbers were altitudes (elevation above or below sea level). } \usage{ beachcolours(range, sealevel = 0, monochrome = FALSE, ncolours = if (monochrome) 16 else 64, nbeach = 1) beachcolourmap(range, ...) } \arguments{ \item{range}{ Range of numerical values to be mapped. A numeric vector of length 2. } \item{sealevel}{ Value that should be treated as zero. A single number, lying between \code{range[1]} and \code{range[2]}. } \item{monochrome}{ Logical. If \code{TRUE} then a greyscale colour map is constructed. } \item{ncolours}{ Number of distinct colours to use. } \item{nbeach}{ Number of colours that will be yellow. } \item{\dots}{Arguments passed to \code{beachcolours}.} } \details{ Given a range of numerical values, these commands create a colour scheme that would be appropriate if the numbers were altitudes (elevation above or below sea level). Numerical values close to zero are portrayed in green (representing the waterline). Negative values are blue (representing water) and positive values are yellow to red (representing land). At least, these are the colours of land and sea in Western Australia. This colour scheme was proposed by Baddeley et al (2005). The function \code{beachcolours} returns these colours as a character vector, while \code{beachcolourmap} returns a colourmap object. The argument \code{range} should be a numeric vector of length 2 giving a range of numerical values. The argument \code{sealevel} specifies the height value that will be treated as zero, and mapped to the colour green. A vector of \code{ncolours} colours will be created, of which \code{nbeach} colours will be green. The argument \code{monochrome} is included for convenience when preparing publications. If \code{monochrome=TRUE} the colour map will be a simple grey scale containing \code{ncolours} shades from black to white. } \value{ For \code{beachcolours}, a character vector of length \code{ncolours} specifying colour values. For \code{beachcolourmap}, a colour map (object of class \code{"colourmap"}). } \references{ Baddeley, A., Turner, R., \Moller, J. and Hazelton, M. (2005) Residual analysis for spatial point processes. \emph{Journal of the Royal Statistical Society, Series B} \bold{67}, 617--666. } \seealso{ \code{\link{colourmap}}, \code{\link[spatstat.geom:colourtools]{colourtools}}. } \examples{ plot(beachcolourmap(c(-2,2))) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{color} spatstat.geom/man/summary.distfun.Rd0000644000176200001440000000347014643111575017270 0ustar liggesusers\name{summary.distfun} \alias{summary.distfun} \alias{summary.funxy} \title{ Summarizing a Function of Spatial Location } \description{ Prints a useful summary of a function of spatial location. } \usage{ \method{summary}{distfun}(object, \dots) \method{summary}{funxy}(object, \dots) } \arguments{ \item{object}{ An object of class \code{"distfun"} or \code{"funxy"} representing a function of spatial coordinates. } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution used to compute the summary. } } \details{ These are the \code{\link[base]{summary}} methods for the classes \code{"funxy"} and \code{"distfun"}. An object of class \code{"funxy"} represents a function of spatial location, defined in a particular region of space. This includes objects of the special class \code{"distfun"} which represent distance functions. The \code{summary} method computes a summary of the function values. The function is evaluated on a grid of locations using \code{\link{as.im}} and numerical values at these locations are summarised using \code{\link{summary.im}}. The pixel resolution for the grid of locations is determined by the arguments \code{\dots} which are passed to \code{\link[spatstat.geom]{as.mask}}. } \value{ For \code{summary.funxy} the result is an object of class \code{"summary.funxy"}. For \code{summary.distfun} the result is an object of class \code{"summary.distfun"}. There are \code{print} methods for these classes. } \author{ \spatstatAuthors. } \seealso{ \code{\link{distfun}}, \code{\link{funxy}} } \examples{ f <- function(x,y) { x^2 + y^2 - 1} g <- funxy(f, square(2)) summary(g) summary(distfun(cells)) summary(distfun(cells), dimyx=256) } \keyword{spatial} \keyword{methods} spatstat.geom/man/transmat.Rd0000644000176200001440000000571314611065351015746 0ustar liggesusers\name{transmat} \alias{transmat} \title{ Convert Pixel Array Between Different Conventions } \description{ This function provides a simple way to convert arrays of pixel data between different display conventions. } \usage{ transmat(m, from, to) } \arguments{ \item{m}{ A matrix. } \item{from,to}{ Specifications of the spatial arrangement of the pixels. See Details. } } \details{ Pixel images are handled by many different software packages. In virtually all of these, the pixel values are stored in a matrix, and are accessed using the row and column indices of the matrix. However, different pieces of software use different conventions for mapping the matrix indices \eqn{[i,j]} to the spatial coordinates \eqn{(x,y)}. \itemize{ \item In the \emph{Cartesian} convention, the first matrix index \eqn{i} is associated with the first Cartesian coordinate \eqn{x}, and \eqn{j} is associated with \eqn{y}. This convention is used in \code{\link[graphics]{image.default}}. \item In the \emph{European reading order} convention, a matrix is displayed in the spatial coordinate system as it would be printed in a page of text: \eqn{i} is effectively associated with the negative \eqn{y} coordinate, and \eqn{j} is associated with \eqn{x}. This convention is used in some image file formats. \item In the \code{spatstat} convention, \eqn{i} is associated with the increasing \eqn{y} coordinate, and \eqn{j} is associated with \eqn{x}. This is also used in some image file formats. } To convert between these conventions, use the function \code{transmat}. If a matrix \code{m} contains pixel image data that is correctly displayed by software that uses the Cartesian convention, and we wish to convert it to the European reading convention, we can type \code{mm <- transmat(m, from="Cartesian", to="European")}. The transformed matrix \code{mm} will then be correctly displayed by software that uses the European convention. Each of the arguments \code{from} and \code{to} can be one of the names \code{"Cartesian"}, \code{"European"} or \code{"spatstat"} (partially matched) or it can be a list specifying another convention. For example \code{to=list(x="-i", y="-j")!} specifies that rows of the output matrix are expected to be displayed as vertical columns in the plot, starting at the right side of the plot, as in the traditional Chinese, Japanese and Korean writing order. } \value{ Another matrix obtained by rearranging the entries of \code{m}. } \author{ \adrian \rolf and \ege } \examples{ opa <- par(mfrow=c(1,2)) # image in spatstat format Z <- bei.extra$elev plot(Z, main="plot.im", ribbon=FALSE) m <- as.matrix(Z) # convert matrix to format suitable for display by image.default Y <- transmat(m, from="spatstat", to="Cartesian") image(Y, asp=0.5, main="image.default", axes=FALSE) par(opa) } \keyword{spatial} \keyword{hplot} \keyword{manip} spatstat.geom/man/deltametric.Rd0000644000176200001440000000570514643111575016420 0ustar liggesusers\name{deltametric} \Rdversion{1.1} \alias{deltametric} \title{ Delta Metric } \description{ Computes the discrepancy between two sets \eqn{A} and \eqn{B} according to Baddeley's delta-metric. } \usage{ deltametric(A, B, p = 2, c = Inf, ...) } \arguments{ \item{A,B}{ The two sets which will be compared. Windows (objects of class \code{"owin"}), point patterns (objects of class \code{"ppp"}) or line segment patterns (objects of class \code{"psp"}). } \item{p}{ Index of the \eqn{L^p} metric. Either a positive numeric value, or \code{Inf}. } \item{c}{ Distance threshold. Either a positive numeric value, or \code{Inf}. } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution of the distance maps computed by \code{\link{distmap}}. } } \details{ Baddeley (1992a, 1992b) defined a distance between two sets \eqn{A} and \eqn{B} contained in a space \eqn{W} by \deqn{ \Delta(A,B) = \left[ \frac 1 {|W|} \int_W \left| \min(c, d(x,A)) - \min(c, d(x,B)) \right|^p \, {\rm d}x \right]^{1/p} }{ \Delta(A,B) = [ (1/|W|) * integral of |min(c, d(x,A))-min(c, d(x,B))|^p dx ]^(1/p) } where \eqn{c \ge 0}{c \ge 0} is a distance threshold parameter, \eqn{0 < p \le \infty}{0 < p \le Inf} is the exponent parameter, and \eqn{d(x,A)} denotes the shortest distance from a point \eqn{x} to the set \eqn{A}. Also \code{|W|} denotes the area or volume of the containing space \eqn{W}. This is defined so that it is a \emph{metric}, i.e. \itemize{ \item \eqn{\Delta(A,B)=0}{\Delta(A,B)=0} if and only if \eqn{A=B} \item \eqn{\Delta(A,B)=\Delta(B,A)}{\Delta(A,B)=\Delta(B,A)} \item \eqn{\Delta(A,C) \le \Delta(A,B) + \Delta(B,C)}{\Delta(A,C) \le \Delta(A,B) + \Delta(B,C)} } It is topologically equivalent to the Hausdorff metric (Baddeley, 1992a) but has better stability properties in practical applications (Baddeley, 1992b). If \eqn{p=\infty}{p=Inf} and \eqn{c=\infty}{c=Inf} the Delta metric is equal to the Hausdorff metric. The algorithm uses \code{\link{distmap}} to compute the distance maps \eqn{d(x,A)} and \eqn{d(x,B)}, then approximates the integral numerically. The accuracy of the computation depends on the pixel resolution which is controlled through the extra arguments \code{\dots} passed to \code{\link[spatstat.geom]{as.mask}}. } \value{ A numeric value. } \references{ Baddeley, A.J. (1992a) Errors in binary images and an \eqn{L^p} version of the Hausdorff metric. \emph{Nieuw Archief voor Wiskunde} \bold{10}, 157--183. Baddeley, A.J. (1992b) An error metric for binary images. In W. Foerstner and S. Ruwiedel (eds) \emph{Robust Computer Vision}. Karlsruhe: Wichmann. Pages 59--78. } \author{ \adrian and \rolf } \seealso{ \code{\link{distmap}} } \examples{ X <- runifrect(20) Y <- runifrect(10) deltametric(X, Y, p=1,c=0.1) } \keyword{spatial} \keyword{math} spatstat.geom/man/nndist.ppx.Rd0000644000176200001440000001031714742317357016231 0ustar liggesusers\name{nndist.ppx} \alias{nndist.ppx} \title{Nearest Neighbour Distances in Any Dimensions} \description{ Computes the distance from each point to its nearest neighbour in a multi-dimensional point pattern. Alternatively computes the distance to the second nearest neighbour, or third nearest, etc. } \usage{ \method{nndist}{ppx}(X, \dots, k=1, by=NULL) } \arguments{ \item{X}{ Multi-dimensional point pattern (object of class \code{"ppx"}). } \item{\dots}{ Arguments passed to \code{\link{coords.ppx}} to determine which coordinates should be used. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } \item{by}{ Optional. A factor, which separates \code{X} into groups. The algorithm will compute the distance to the nearest point in each group. } } \value{ Numeric vector or matrix containing the nearest neighbour distances for each point. If \code{k = 1} (the default), the return value is a numeric vector \code{v} such that \code{v[i]} is the nearest neighbour distance for the \code{i}th data point. If \code{k} is a single integer, then the return value is a numeric vector \code{v} such that \code{v[i]} is the \code{k}th nearest neighbour distance for the \code{i}th data point. If \code{k} is a vector, then the return value is a matrix \code{m} such that \code{m[i,j]} is the \code{k[j]}th nearest neighbour distance for the \code{i}th data point. } \details{ This function computes the Euclidean distance from each point in a multi-dimensional point pattern to its nearest neighbour (the nearest other point of the pattern). If \code{k} is specified, it computes the distance to the \code{k}th nearest neighbour. The function \code{nndist} is generic; this function \code{nndist.ppx} is the method for the class \code{"ppx"}. The argument \code{k} may be a single integer, or an integer vector. If it is a vector, then the \eqn{k}th nearest neighbour distances are computed for each value of \eqn{k} specified in the vector. If there is only one point (if \code{x} has length 1), then a nearest neighbour distance of \code{Inf} is returned. If there are no points (if \code{x} has length zero) a numeric vector of length zero is returned. If the argument \code{by} is given, it should be a \code{factor}, of length equal to the number of points in \code{X}. This factor effectively partitions \code{X} into subsets, each subset associated with one of the levels of \code{X}. The algorithm will then compute, for each point of \code{X}, the distance to the nearest neighbour \emph{in each subset}. To identify \emph{which} point is the nearest neighbour of a given point, use \code{\link{nnwhich}}. To find the nearest neighbour distances from one point pattern to another point pattern, use \code{\link{nncross}}. By default, both spatial and temporal coordinates are extracted. To obtain the spatial distance between points in a space-time point pattern, set \code{temporal=FALSE}. } \section{Distance values}{ The values returned by \code{nndist(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{nndist(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \section{Warnings}{ An infinite or \code{NA} value is returned if the distance is not defined (e.g. if there is only one point in the point pattern). } \seealso{ \code{\link{nndist}}, \code{\link{pairdist}}, \code{\link{nnwhich}} } \examples{ df <- data.frame(x=runif(5),y=runif(5),z=runif(5),w=runif(5)) X <- ppx(data=df) # nearest neighbours d <- nndist(X) # second nearest neighbours d2 <- nndist(X, k=2) # first, second and third nearest d1to3 <- nndist(X, k=1:3) # nearest neighbour distances to each group marks(X) <- factor(c("a","a", "b", "b", "b")) nndist(X, by=marks(X)) nndist(X, by=marks(X), k=1:2) } \author{ \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/anylist.Rd0000644000176200001440000000221314611065345015573 0ustar liggesusers\name{anylist} \alias{anylist} \alias{as.anylist} \title{ List of Objects } \description{ Make a list of objects of any type. } \usage{ anylist(\dots) as.anylist(x) } \arguments{ \item{\dots}{ Any number of arguments of any type. } \item{x}{ A list. } } \details{ An object of class \code{"anylist"} is a list of objects that the user intends to treat in a similar fashion. For example it may be desired to plot each of the objects side-by-side: this can be done using the function \code{\link{plot.anylist}}. The objects can belong to any class; they may or may not all belong to the same class. In the \pkg{spatstat} package, various functions produce an object of class \code{"anylist"}. } \value{ A list, belonging to the class \code{"anylist"}, containing the original objects. } \author{\adrian \rolf and \ege } \seealso{ \code{\link{solist}}, \code{\link{as.solist}}, \code{\link{anylapply}}. } \examples{ if(require(spatstat.explore)) { anylist(cells, intensity(cells), Kest(cells)) } else { anylist(cells, intensity(cells)) } anylist() } \keyword{list} \keyword{manip} spatstat.geom/man/harmoniseLevels.Rd0000644000176200001440000000234414611065346017256 0ustar liggesusers\name{harmoniseLevels} \alias{harmoniseLevels} \title{ Harmonise the levels of several factors, or factor-valued pixel images. } \description{ Given several factors (or factor-valued pixel images) convert them so that they all use the same set of levels. } \usage{ harmoniseLevels(...) } \arguments{ \item{\dots}{ Factors, or factor-valued pixel images. } } \details{ All of the arguments \code{\dots} must be factors, or factor-valued pixel images (objects of class \code{"im"}). The \code{\link{levels}} of each factor will be extracted, and combined by taking the union of all the levels. Then each factor will be converted to a new factor so that all of the new factors have exactly the same set of levels. } \value{ A list, containing the same number of arguments as the input, consisting of factors or factor-valued pixel images. } \author{ \adrian. } \seealso{ \code{\link{levels}}, \code{\link{levels.im}}, \code{\link[spatstat.geom]{mergeLevels}}. } \examples{ (a <- factor(sample(letters[1:3], 10, replace=TRUE))) (b <- factor(sample(LETTERS[1:4], 7, replace=TRUE))) harmoniseLevels(a,b) (A <- gorillas.extra$vegetation) (B <- gorillas.extra$slopetype) harmoniseLevels(A,B) } \keyword{manip} spatstat.geom/man/pairdist.Rd0000644000176200001440000000345514742317357015750 0ustar liggesusers\name{pairdist} \alias{pairdist} \title{Pairwise distances} \description{ Computes the matrix of distances between all pairs of `things' in a dataset } \usage{ pairdist(X, \dots) } \arguments{ \item{X}{ Object specifying the locations of a set of `things' (such as a set of points or a set of line segments). } \item{\dots}{ Further arguments depending on the method. } } \value{ A square matrix whose \code{[i,j]} entry is the distance between the `things' numbered \code{i} and \code{j}. } \details{ Given a dataset \code{X} and \code{Y} (representing either a point pattern or a line segment pattern) \code{pairdist} computes the distance between each pair of `things' in the dataset, and returns a matrix containing these distances. The function \code{pairdist} is generic, with methods for point patterns (objects of class \code{"ppp"}), line segment patterns (objects of class \code{"psp"}) and a default method. See the documentation for \code{\link{pairdist.ppp}}, \code{\link{pairdist.psp}} or \code{\link{pairdist.default}} for details. } \section{Distance values}{ The values returned by \code{pairdist(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{pairdist(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{pairdist.ppp}}, \code{\link{pairdist.psp}}, \code{\link{pairdist.default}}, \code{\link{crossdist}}, \code{\link{nndist}}, \code{\link[spatstat.explore]{Kest}} } \author{ \pavel and \adrian. } \keyword{spatial} \keyword{math} spatstat.geom/man/rescue.rectangle.Rd0000644000176200001440000000252614611065350017344 0ustar liggesusers\name{rescue.rectangle} \alias{rescue.rectangle} \title{Convert Window Back To Rectangle} \description{ Determines whether the given window is really a rectangle aligned with the coordinate axes, and if so, converts it to a rectangle object. } \usage{ rescue.rectangle(W) } \arguments{ \item{W}{A window (object of class \code{"owin"}).} } \value{ Another object of class \code{"owin"} representing the same window. } \details{ This function decides whether the window \code{W} is actually a rectangle aligned with the coordinate axes. This will be true if \code{W} is \itemize{ \item a rectangle (window object of type \code{"rectangle"}); \item a polygon (window object of type \code{"polygonal"} with a single polygonal boundary) that is a rectangle aligned with the coordinate axes; \item a binary mask (window object of type \code{"mask"}) in which all the pixel entries are \code{TRUE}. } If so, the function returns this rectangle, a window object of type \code{"rectangle"}. If not, the function returns \code{W}. } \seealso{ \code{\link{as.owin}}, \code{\link{owin.object}} } \examples{ w <- owin(poly=list(x=c(0,1,1,0),y=c(0,0,1,1))) rw <- rescue.rectangle(w) w <- as.mask(unit.square()) rw <- rescue.rectangle(w) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/owin2mask.Rd0000644000176200001440000001160214643111575016026 0ustar liggesusers\name{owin2mask} \alias{owin2mask} \title{ Convert Window to Binary Mask under Constraints } \description{ Converts a window (object of class \code{"owin"}) to a binary pixel mask, with options to require that the inside, outside, and/or boundary of the window should be completely covered. } \usage{ owin2mask(W, op = c("sample", "notsample", "cover", "inside", "uncover", "outside", "boundary", "majority", "minority"), \dots) } \arguments{ \item{W}{ A window (object of class \code{"owin"}). } \item{op}{ Character string (partially matched) specifying how \code{W} should be converted to a binary pixel mask. } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution. } } \details{ This function is similar to, but more flexible than, \code{\link[spatstat.geom]{as.mask}}. It converts the interior, exterior, or boundary of the window \code{W} to a binary pixel mask. \itemize{ \item If \code{op="sample"} (the default), the mask consists of all pixels whose \bold{centres} lie inside the window \code{W}. This is the same as using \code{\link[spatstat.geom]{as.mask}}. \item If \code{op="notsample"}, the mask consists of all pixels whose \emph{centres lie outside} the window \code{W}. This is the same as using \code{\link[spatstat.geom]{as.mask}} followed by \code{\link{complement.owin}}. \item If \code{op="cover"}, the mask consists of all pixels which overlap the window \code{W}, wholly or partially. \item If \code{op="inside"}, the mask consists of all pixels which lie entirely inside the window \code{W}. \item If \code{op="uncover"}, the mask consists of all pixels which overlap the outside of the window \code{W}, wholly or partially. \item If \code{op="outside"}, the mask consists of all pixels which lie entirely outside the window \code{W}. \item If \code{op="boundary"}, the mask consists of all pixels which overlap the boundary of the window \code{W}. \item If \code{op="majority"}, the mask consists of all pixels in which at least half of the pixel area is covered by the window \code{W}. \item If \code{op="minority"}, the mask consists of all pixels in which less than half of the pixel area is covered by the window \code{W}. } These operations are complementary pairs as follows: \tabular{lll}{ \code{"notsample"} \tab is the complement of \tab \code{"sample"} \cr \code{"uncover"} \tab is the complement of \tab \code{"inside"} \cr \code{"outside"} \tab is the complement of \tab \code{"cover"} \cr \code{"minority"} \tab is the complement of \tab \code{"majority"} } They also satisfy the following set relations: \tabular{lll}{ \code{"inside"} \tab is a subset of \tab \code{"cover"} \cr \code{"outside"} \tab is a subset of \tab \code{"uncover"} \cr \code{"boundary"} \tab is a subset of \tab \code{"cover"} \cr \code{"boundary"} \tab is a subset of \tab \code{"uncover"} } The results of \code{"inside"}, \code{"boundary"} and \code{"outside"} are disjoint and their union is the entire frame. Theoretically \code{"sample"} should be a subset of \code{"cover"}, \code{"notsample"} should be a subset of \code{"uncover"}, \code{"inside"} should be a subset of \code{"majority"} and \code{"outside"} should be a subset of \code{"minority"}, but these could be false due to numerical error in computational geometry. } \value{ A mask (object of class \code{"owin"} of type \code{"mask"} representing a binary pixel mask). } \author{ \adrian. } \seealso{ \code{\link[spatstat.geom]{as.mask}} } \examples{ W <- Window(chorley) opa <- par(mfrow=c(2,5)) plot(as.mask(W, dimyx=10), col="grey", main="sample") plot(W, add=TRUE, lwd=3, border="red") plot(owin2mask(W, "ma", dimyx=10), col="grey", main="majority") plot(W, add=TRUE, lwd=3, border="red") plot(owin2mask(W, "i", dimyx=10), col="grey", main="inside") plot(W, add=TRUE, lwd=3, border="red") plot(owin2mask(W, "c", dimyx=10), col="grey", main="cover") plot(W, add=TRUE, lwd=3, border="red") plot(owin2mask(W, "b", dimyx=10), col="grey", main="boundary") plot(W, add=TRUE, lwd=3, border="red") plot(as.mask(complement.owin(W), dimyx=10), col="grey", main="notsample") plot(W, add=TRUE, lwd=3, border="red") plot(owin2mask(W, "mi", dimyx=10), col="grey", main="minority") plot(W, add=TRUE, lwd=3, border="red") plot(owin2mask(W, "o", dimyx=10), col="grey", main="outside") plot(W, add=TRUE, lwd=3, border="red") plot(owin2mask(W, "u", dimyx=10), col="grey", main="uncover") plot(W, add=TRUE, lwd=3, border="red") plot(owin2mask(W, "b", dimyx=10), col="grey", main="boundary") plot(W, add=TRUE, lwd=3, border="red") par(opa) } \keyword{spatial} \keyword{manip} spatstat.geom/man/pairdist.ppp.Rd0000644000176200001440000000576614742317357016555 0ustar liggesusers\name{pairdist.ppp} \alias{pairdist.ppp} \title{Pairwise distances} \description{ Computes the matrix of distances between all pairs of points in a point pattern. } \usage{ \method{pairdist}{ppp}(X, \dots, periodic=FALSE, method="C", squared=FALSE, metric=NULL) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"}). } \item{\dots}{ Ignored. } \item{periodic}{ Logical. Specifies whether to apply a periodic edge correction. } \item{method}{ String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. Usually not specified. } \item{squared}{ Logical. If \code{squared=TRUE}, the squared distances are returned instead (this computation is faster). } \item{metric}{ Optional. A metric (object of class \code{"metric"}) that will be used to define and compute the distances. } } \value{ A square matrix whose \code{[i,j]} entry is the distance between the points numbered \code{i} and \code{j}. } \details{ This is a method for the generic function \code{pairdist}. Given a point pattern \code{X} (an object of class \code{"ppp"}), this function computes the Euclidean distances between all pairs of points in \code{X}, and returns the matrix of distances. Alternatively if \code{periodic=TRUE} and the window containing \code{X} is a rectangle, then the distances will be computed in the `periodic' sense (also known as `torus' distance): opposite edges of the rectangle are regarded as equivalent. This is meaningless if the window is not a rectangle. If \code{squared=TRUE} then the \emph{squared} Euclidean distances \eqn{d^2} are returned, instead of the Euclidean distances \eqn{d}. The squared distances are faster to calculate, and are sufficient for many purposes (such as finding the nearest neighbour of a point). The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted R code only. If \code{method="C"} (the default) then C code is used. The C code is somewhat faster. } \section{Distance values}{ The values returned by \code{pairdist(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{pairdist(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{pairdist}}, \code{\link{pairdist.default}}, \code{\link{pairdist.psp}}, \code{\link{crossdist}}, \code{\link{nndist}}, \code{\link[spatstat.explore]{Kest}} } \examples{ d <- pairdist(cells) d <- pairdist(cells, periodic=TRUE) d <- pairdist(cells, squared=TRUE) } \author{ \pavel and \adrian. } \keyword{spatial} \keyword{math} spatstat.geom/man/is.subset.owin.Rd0000644000176200001440000000252014643111575017005 0ustar liggesusers\name{is.subset.owin} \alias{is.subset.owin} \title{Determine Whether One Window is Contained In Another} \description{ Tests whether window \code{A} is a subset of window \code{B}. } \usage{ is.subset.owin(A, B) } \arguments{ \item{A}{A window object (see Details).} \item{B}{A window object (see Details).} } \value{ Logical scalar; \code{TRUE} if \code{A} is a sub-window of \code{B}, otherwise \code{FALSE}. } \details{ This function tests whether the window \code{A} is a subset of the window \code{B}. The arguments \code{A} and \code{B} must be window objects (either objects of class \code{"owin"}, or data that can be coerced to this class by \code{\link{as.owin}}). Various algorithms are used, depending on the geometrical type of the two windows. Note that if \code{B} is not rectangular, the algorithm proceeds by discretising \code{A}, converting it to a pixel mask using \code{\link[spatstat.geom]{as.mask}}. In this case the resulting answer is only ``approximately correct''. The accuracy of the approximation can be controlled: see \code{\link[spatstat.geom]{as.mask}}. } \author{\adrian and \rolf } \examples{ w1 <- as.owin(c(0,1,0,1)) w2 <- as.owin(c(-1,2,-1,2)) is.subset.owin(w1,w2) # Returns TRUE. is.subset.owin(w2,w1) # Returns FALSE. } \keyword{spatial} \keyword{math} spatstat.geom/man/macros/0000755000176200001440000000000014611065344015106 5ustar liggesusersspatstat.geom/man/macros/defns.Rd0000755000176200001440000001134014765164151016504 0ustar liggesusers%% macro definitions for spatstat man pages %% Authors \newcommand{\adrian}{Adrian Baddeley \email{Adrian.Baddeley@curtin.edu.au}} \newcommand{\rolf}{Rolf Turner \email{rolfturner@posteo.net}} \newcommand{\ege}{Ege Rubak \email{rubak@math.aau.dk}} \newcommand{\spatstatAuthors}{\adrian, \rolf and \ege} \newcommand{\spatstatAuthorsComma}{\adrian, \rolf, \ege} %% Contributors with emails \newcommand{\pavel}{Pavel Grabarnik \email{pavel.grabar@issp.serpukhov.su}} \newcommand{\dominic}{Dominic Schuhmacher \email{dominic.schuhmacher@mathematik.uni-goettingen.de}, URL \code{http://dominic.schuhmacher.name/}} \newcommand{\wei}{Ang Qi Wei \email{aqw07398@hotmail.com}} \newcommand{\colette}{Marie-Colette van Lieshout \email{Marie-Colette.van.Lieshout@cwi.nl}} \newcommand{\rasmus}{Rasmus Plenge Waagepetersen \email{rw@math.auc.dk}} \newcommand{\abdollah}{Abdollah Jalilian \email{jalilian@razi.ac.ir}} \newcommand{\ottmar}{Ottmar Cronie \email{ottmar@chalmers.se}} \newcommand{\stephenEglen}{Stephen Eglen \email{S.J.Eglen@damtp.cam.ac.uk}} \newcommand{\mehdi}{Mehdi Moradi \email{m2.moradi@yahoo.com}} \newcommand{\yamei}{Ya-Mei Chang \email{yamei628@gmail.com}} \newcommand{\martinH}{Martin Hazelton \email{Martin.Hazelton@otago.ac.nz}} \newcommand{\tilman}{Tilman Davies \email{Tilman.Davies@otago.ac.nz}} % Names with accents \newcommand{\Bogsted}{\ifelse{latex}{\out{B\o gsted}}{Bogsted}} \newcommand{\Cramer}{\ifelse{latex}{\out{Cram\'er}}{Cramer}} \newcommand{\Francois}{\ifelse{latex}{\out{Fran\c{c}ois}}{Francois}} \newcommand{\Frederic}{\ifelse{latex}{\out{Fr{\'e}d{\'e}ric}}{Frederic}} \newcommand{\Hogmander}{\ifelse{latex}{\out{H{\"o}gmander}}{Hogmander}} \newcommand{\Jyvaskyla}{\ifelse{latex}{\out{Jyv\"askyl\"a}}{Jyvaskyla}} \newcommand{\Lucia}{\ifelse{latex}{\out{Luc\'{\i{}}a}}{Lucia}} \newcommand{\Matern}{\ifelse{latex}{\out{Mat\'ern}}{Matern}} \newcommand{\Moller}{\ifelse{latex}{\out{M\o ller}}{Moller}} \newcommand{\Oehlschlaegel}{\ifelse{latex}{\out{Oehlschl\"{a}gel}}{Oehlschlaegel}} \newcommand{\Prokesova}{\ifelse{latex}{\out{Proke\u{s}ov{\'{a}}}}{Prokesova}} \newcommand{\Sarkka}{\ifelse{latex}{\out{S\"{a}rkk\"{a}}}{Sarkka}} \newcommand{\Sanchez}{\ifelse{latex}{\out{S\'{a}nchez}}{Sanchez}} \newcommand{\Martin}{\ifelse{latex}{\out{Mart\'{\i}n}}{Martin}} \newcommand{\Dominguez}{\ifelse{latex}{\out{Dom\'{\i}nguez}}{Dominguez}} \newcommand{\Rodriguez}{\ifelse{latex}{\out{Rodr\'{\i}guez}}{Rodriguez}} \newcommand{\Gonzalez}{\ifelse{latex}{\out{Gonz\'{a}lez}}{Gonzalez}} %% List of all Gibbs interactions \newcommand{\GibbsInteractionsList}{\code{\link[MPKG]{AreaInter}}, \code{\link[MPKG]{BadGey}}, \code{\link[MPKG]{Concom}}, \code{\link[MPKG]{DiggleGatesStibbard}}, \code{\link[MPKG]{DiggleGratton}}, \code{\link[MPKG]{Fiksel}}, \code{\link[MPKG]{Geyer}}, \code{\link[MPKG]{Hardcore}}, \code{\link[MPKG]{HierHard}}, \code{\link[MPKG]{HierStrauss}}, \code{\link[MPKG]{HierStraussHard}}, \code{\link[MPKG]{Hybrid}}, \code{\link[MPKG]{LennardJones}}, \code{\link[MPKG]{MultiHard}}, \code{\link[MPKG]{MultiStrauss}}, \code{\link[MPKG]{MultiStraussHard}}, \code{\link[MPKG]{OrdThresh}}, \code{\link[MPKG]{Ord}}, \code{\link[MPKG]{Pairwise}}, \code{\link[MPKG]{PairPiece}}, \code{\link[MPKG]{Penttinen}}, \code{\link[MPKG]{Poisson}}, \code{\link[MPKG]{Saturated}}, \code{\link[MPKG]{SatPiece}}, \code{\link[MPKG]{Softcore}}, \code{\link[MPKG]{Strauss}}, \code{\link[MPKG]{StraussHard}} and \code{\link[MPKG]{Triplets}}} %% List of interactions recognised by RMH code \newcommand{\rmhInteractionsList}{\code{\link[MPKG]{AreaInter}}, \code{\link[MPKG]{BadGey}}, \code{\link[MPKG]{DiggleGatesStibbard}}, \code{\link[MPKG]{DiggleGratton}}, \code{\link[MPKG]{Fiksel}}, \code{\link[MPKG]{Geyer}}, \code{\link[MPKG]{Hardcore}}, \code{\link[MPKG]{Hybrid}}, \code{\link[MPKG]{LennardJones}}, \code{\link[MPKG]{MultiStrauss}}, \code{\link[MPKG]{MultiStraussHard}}, \code{\link[MPKG]{PairPiece}}, \code{\link[MPKG]{Penttinen}}, \code{\link[MPKG]{Poisson}}, \code{\link[MPKG]{Softcore}}, \code{\link[MPKG]{Strauss}}, \code{\link[MPKG]{StraussHard}} and \code{\link[MPKG]{Triplets}}} %% Frequent references \newcommand{\baddrubaturnbook}{Baddeley, A., Rubak, E. and Turner, R. (2015) \emph{Spatial Point Patterns: Methodology and Applications with R}. Chapman and Hall/CRC Press. } %% Citations of recent articles that will change rapidly \newcommand{\baddchangclustersim}{Baddeley, A. and Chang, Y.-M. (2023) Robust algorithms for simulating cluster point processes. \emph{Journal of Statistical Computation and Simulation} \bold{93}, 1950--1975.} \newcommand{\smoothpcfpaper}{Baddeley, A., Davies, T.M. and Hazelton, M.L. (2025) An improved estimator of the pair correlation function of a spatial point process. \emph{Biometrika}, to appear.} \newcommand{\smoothpcfpapercite}{Baddeley, Davies and Hazelton (2025)} spatstat.geom/man/crossdist.default.Rd0000644000176200001440000000520514611065345017554 0ustar liggesusers\name{crossdist.default} \alias{crossdist.default} \title{Pairwise distances between two different sets of points} \description{ Computes the distances between each pair of points taken from two different sets of points. } \usage{ \method{crossdist}{default}(X, Y, x2, y2, \dots, period=NULL, method="C", squared=FALSE) } \arguments{ \item{X,Y}{ Numeric vectors of equal length specifying the coordinates of the first set of points. } \item{x2,y2}{ Numeric vectors of equal length specifying the coordinates of the second set of points. } \item{\dots}{ Ignored. } \item{period}{ Optional. Dimensions for periodic edge correction. } \item{method}{ String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. } \item{squared}{ Logical. If \code{squared=TRUE}, the squared distances are returned instead (this computation is faster). } } \value{ A matrix whose \code{[i,j]} entry is the distance from the \code{i}-th point in the first set of points to the \code{j}-th point in the second set of points. } \details{ Given two sets of points, this function computes the Euclidean distance from each point in the first set to each point in the second set, and returns a matrix containing these distances. This is a method for the generic function \code{\link{crossdist}}. This function expects \code{X} and \code{Y} to be numeric vectors of equal length specifying the coordinates of the first set of points. The arguments \code{x2},\code{y2} specify the coordinates of the second set of points. Alternatively if \code{period} is given, then the distances will be computed in the `periodic' sense (also known as `torus' distance). The points will be treated as if they are in a rectangle of width \code{period[1]} and height \code{period[2]}. Opposite edges of the rectangle are regarded as equivalent. The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted R code only. If \code{method="C"} (the default) then C code is used. The C code is faster by a factor of 4. } \seealso{ \code{\link{crossdist}}, \code{\link{crossdist.ppp}}, \code{\link{crossdist.psp}}, \code{\link{pairdist}}, \code{\link{nndist}}, \code{\link[spatstat.explore]{Gest}} } \examples{ d <- crossdist(runif(7), runif(7), runif(12), runif(12)) d <- crossdist(runif(7), runif(7), runif(12), runif(12), period=c(1,1)) } \author{ \pavel and \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/pixelquad.Rd0000644000176200001440000000612214700461464016110 0ustar liggesusers\name{pixelquad} \alias{pixelquad} \title{Quadrature Scheme Based on Pixel Grid} \description{ Makes a quadrature scheme with a dummy point at every pixel of a pixel image. } \usage{ pixelquad(X, W = as.owin(X), \dots) } \arguments{ \item{X}{Point pattern (object of class \code{"ppp"}) containing the data points for the quadrature scheme. } \item{W}{ Specifies the pixel grid. A pixel image (object of class \code{"im"}), a window (object of class \code{"owin"}), or anything that can be converted to a window by \code{\link{as.owin}}. } \item{\dots}{ Optional arguments to \code{\link[spatstat.geom]{as.mask}} controlling the pixel raster dimensions. } } \value{ An object of class \code{"quad"} describing the quadrature scheme (data points, dummy points, and quadrature weights) suitable as the argument \code{Q} of the function \code{\link[spatstat.model]{ppm}()} for fitting a point process model. The quadrature scheme can be inspected using the \code{print} and \code{plot} methods for objects of class \code{"quad"}. } \details{ This is a method for producing a quadrature scheme for use by \code{\link[spatstat.model]{ppm}}. It is an alternative to \code{\link{quadscheme}}. The function \code{\link[spatstat.model]{ppm}} fits a point process model to an observed point pattern using the Berman-Turner quadrature approximation (Berman and Turner, 1992; Baddeley and Turner, 2000) to the pseudolikelihood of the model. It requires a quadrature scheme consisting of the original data point pattern, an additional pattern of dummy points, and a vector of quadrature weights for all these points. Such quadrature schemes are represented by objects of class \code{"quad"}. See \code{\link{quad.object}} for a description of this class. Given a grid of pixels, this function creates a quadrature scheme in which there is one dummy point at the centre of each pixel. The counting weights are used (the weight attached to each quadrature point is 1 divided by the number of quadrature points falling in the same pixel). The argument \code{X} specifies the locations of the data points for the quadrature scheme. Typically this would be a point pattern dataset. The argument \code{W} specifies the grid of pixels for the dummy points of the quadrature scheme. It should be a pixel image (object of class \code{"im"}), a window (object of class \code{"owin"}), or anything that can be converted to a window by \code{\link{as.owin}}. If \code{W} is a pixel image or a binary mask (a window of type \code{"mask"}) then the pixel grid of \code{W} will be used. If \code{W} is a rectangular or polygonal window, then it will first be converted to a binary mask using \code{\link[spatstat.geom]{as.mask}} at the default pixel resolution. } \examples{ W <- owin(c(0,1),c(0,1)) X <- runifrect(42, W) W <- as.mask(W,dimyx=128) pixelquad(X,W) } \seealso{ \code{\link{quadscheme}}, \code{\link{quad.object}}, \code{\link[spatstat.model]{ppm}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/volume.Rd0000644000176200001440000000170414611065351015420 0ustar liggesusers\name{volume} \alias{volume} \title{Volume of an Object} \description{ Computes the volume of a spatial object such as a three-dimensional box. } \usage{ volume(x) } \arguments{ \item{x}{ An object whose volume will be computed. } } \value{ The numerical value of the volume of the object. } \details{ This function computes the volume of an object such as a three-dimensional box. The function \code{volume} is generic, with methods for the classes \code{"box3"} (three-dimensional boxes) and \code{"boxx"} (multi-dimensional boxes). There is also a method for the class \code{"owin"} (two-dimensional windows), which is identical to \code{\link{area.owin}}, and a method for the class \code{"linnet"} of linear networks, which returns the length of the network. } \seealso{ \code{\link{area.owin}}, \code{\link{volume.box3}}, \code{\link{volume.boxx}}. } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/Extract.solist.Rd0000644000176200001440000000306014611065346017040 0ustar liggesusers\name{Extract.solist} \alias{[.solist} \alias{[<-.solist} \title{Extract or Replace Subset of a List of Spatial Objects} \description{ Extract or replace some entries in a list of spatial objects, or extract a designated sub-region in each object. } \usage{ \method{[}{solist}(x, i, \dots) \method{[}{solist}(x, i) <- value } \arguments{ \item{x}{ An object of class \code{"solist"} representing a list of two-dimensional spatial objects. } \item{i}{ Subset index. Any valid subset index for vectors in the usual \R sense, or a window (object of class \code{"owin"}). } \item{value}{ Replacement value for the subset. } \item{\dots}{Ignored.} } \value{ Another object of the same class as \code{x}. } \details{ These are methods for extracting and replacing subsets for the class \code{"solist"}. The argument \code{x} should be an object of class \code{"solist"} representing a list of two-dimensional spatial objects. See \code{\link{solist}}. For the subset method, the subset index \code{i} can be either a vector index (specifying some elements of the list) or a spatial window (specifying a spatial sub-region). For the replacement method, \code{i} must be a vector index: the designated elements will be replaced. } \seealso{ \code{\link{solist}}, \code{\link{plot.solist}}, \code{\link{summary.solist}} } \examples{ x <- solist(japanesepines, cells, redwood) x[2:3] x[square(0.5)] x[1] <- list(finpines) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{list} \keyword{manip} spatstat.geom/man/crossdist.ppp.Rd0000644000176200001440000000522714611065345016733 0ustar liggesusers\name{crossdist.ppp} \alias{crossdist.ppp} \title{Pairwise distances between two different point patterns} \description{ Computes the distances between pairs of points taken from two different point patterns. } \usage{ \method{crossdist}{ppp}(X, Y, \dots, periodic=FALSE, method="C", squared=FALSE, metric=NULL) } \arguments{ \item{X,Y}{ Point patterns (objects of class \code{"ppp"}). } \item{\dots}{ Ignored. } \item{periodic}{ Logical. Specifies whether to apply a periodic edge correction. } \item{method}{ String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. } \item{squared}{ Logical. If \code{squared=TRUE}, the squared distances are returned instead (this computation is faster). } \item{metric}{ Optional. A distance metric (object of class \code{"metric"}, see \code{\link{metric.object}}) which will be used to compute the distances. } } \value{ A matrix whose \code{[i,j]} entry is the distance from the \code{i}-th point in \code{X} to the \code{j}-th point in \code{Y}. } \details{ Given two point patterns, this function computes the Euclidean distance from each point in the first pattern to each point in the second pattern, and returns a matrix containing these distances. This is a method for the generic function \code{\link{crossdist}} for point patterns (objects of class \code{"ppp"}). This function expects two point patterns \code{X} and \code{Y}, and returns the matrix whose \code{[i,j]} entry is the distance from \code{X[i]} to \code{Y[j]}. Alternatively if \code{periodic=TRUE}, then provided the windows containing \code{X} and \code{Y} are identical and are rectangular, then the distances will be computed in the `periodic' sense (also known as `torus' distance): opposite edges of the rectangle are regarded as equivalent. This is meaningless if the window is not a rectangle. The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted R code only. If \code{method="C"} (the default) then C code is used. The C code is faster by a factor of 4. } \seealso{ \code{\link{crossdist}}, \code{\link{crossdist.default}}, \code{\link{crossdist.psp}}, \code{\link{pairdist}}, \code{\link{nndist}}, \code{\link[spatstat.explore]{Gest}} } \examples{ Y <- runifrect(6, Window(cells)) d <- crossdist(cells, Y) d <- crossdist(cells, Y, periodic=TRUE) } \author{ \pavel and \adrian. } \keyword{spatial} \keyword{math} spatstat.geom/man/im.object.Rd0000644000176200001440000000717014611065346015772 0ustar liggesusers\name{im.object} \alias{im.object} %DoNotExport \title{Class of Images} \description{ A class \code{"im"} to represent a two-dimensional pixel image. } \details{ An object of this class represents a two-dimensional pixel image. It specifies \itemize{ \item the dimensions of the rectangular array of pixels \item \eqn{x} and \eqn{y} coordinates for the pixels \item a numeric value (``grey value'') at each pixel } If \code{X} is an object of type \code{im}, it contains the following elements: \tabular{ll}{ \code{v} \tab matrix of values \cr \code{dim} \tab dimensions of matrix \code{v} \cr \code{xrange} \tab range of \eqn{x} coordinates of image window \cr \code{yrange} \tab range of \eqn{y} coordinates of image window \cr \code{xstep} \tab width of one pixel \cr \code{ystep} \tab height of one pixel \cr \code{xcol} \tab vector of \eqn{x} coordinates of centres of pixels \cr \code{yrow} \tab vector of \eqn{y} coordinates of centres of pixels } Users are strongly advised not to manipulate these entries directly. Objects of class \code{"im"} may be created by the functions \code{\link{im}} and \code{\link{as.im}}. Image objects are also returned by various functions including \code{\link{distmap}}, \code{\link[spatstat.explore]{Kmeasure}}, \code{\link{setcov}}, \code{\link{eval.im}} and \code{\link{cut.im}}. Image objects may be displayed using the methods \code{\link{plot.im}}, \code{image.im}, \code{\link{persp.im}} and \code{contour.im}. There are also methods \code{\link{print.im}} for printing information about an image, \code{\link{summary.im}} for summarising an image, \code{\link{mean.im}} for calculating the average pixel value, \code{\link{hist.im}} for plotting a histogram of pixel values, \code{\link{quantile.im}} for calculating quantiles of pixel values, and \code{\link{cut.im}} for dividing the range of pixel values into categories. Pixel values in an image may be extracted using the subset operator \code{\link{[.im}}. To extract all pixel values from an image object, use \code{\link{as.matrix.im}}. The levels of a factor-valued image can be extracted and changed with \code{levels} and \code{levels<-}. Calculations involving one or more images (for example, squaring all the pixel values in an image, converting numbers to factor levels, or subtracting one image from another) can often be done easily using \code{\link{eval.im}}. To find all pixels satisfying a certain constraint, use \code{\link{solutionset}}. Note carefully that the entry \code{v[i,j]} gives the pixel value at the location \code{(xcol[j],yrow[i]}. That is, the \bold{row} index of the matrix \code{v} corresponds to increasing \bold{y} coordinate, while the column index of \code{mat} corresponds to increasing \bold{x} coordinate. Thus \code{yrow} has one entry for each row of \code{v} and \code{xcol} has one entry for each column of \code{v}. Under the usual convention in \R, a correct display of the image would be obtained by transposing the matrix, e.g. \code{image.default(xcol, yrow, t(v))}, if you wanted to do it by hand. } \seealso{ \code{\link{im}}, \code{\link{as.im}}, \code{\link{plot.im}}, \code{\link{persp.im}}, \code{\link{eval.im}}, \code{\link{[.im}} } \section{Warnings}{ The internal representation of images is likely to change in future releases of \pkg{spatstat}. Do not address the entries in an image directly. To extract all pixel values from an image object, use \code{\link{as.matrix.im}}. } \author{\adrian and \rolf } \keyword{spatial} \keyword{attribute} spatstat.geom/man/tilenames.Rd0000644000176200001440000000171314611065351016072 0ustar liggesusers\name{tilenames} \alias{tilenames} \alias{tilenames<-} \alias{tilenames.tess} \alias{tilenames<-.tess} \title{Names of Tiles in a Tessellation} \description{ Extract or Change the Names of the Tiles in a Tessellation. } \usage{ tilenames(x) tilenames(x) <- value \method{tilenames}{tess}(x) \method{tilenames}{tess}(x) <- value } \arguments{ \item{x}{ A tessellation (object of class \code{"tess"}). } \item{value}{Character vector giving new names for the tiles.} } \details{ These functions extract or change the names of the tiles that make up the tessellation \code{x}. If the tessellation is a regular grid, the tile names cannot be changed. } \value{ \code{tilenames} returns a character vector. } \seealso{ \code{\link{tess}}, \code{\link{tiles}} } \examples{ D <- dirichlet(runifrect(10)) tilenames(D) tilenames(D) <- paste("Cell", 1:10) tilenames(D) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/mean.im.Rd0000644000176200001440000000446614611065347015452 0ustar liggesusers\name{mean.im} %DontDeclareMethods \alias{mean.im} \alias{median.im} \title{Mean and Median of Pixel Values in an Image} \description{ Calculates the mean or median of the pixel values in a pixel image. } %NAMESPACE S3method("mean", "im") %NAMESPACE S3method("median", "im") \usage{ ## S3 method for class 'im' ## mean(x, trim=0, na.rm=TRUE, ...) ## S3 method for class 'im' ## median(x, na.rm=TRUE) [R < 3.4.0] ## median(x, na.rm=TRUE, ...) [R >= 3.4.0] } \arguments{ \item{x}{A pixel image (object of class \code{"im"}).} \item{na.rm}{ Logical value indicating whether \code{NA} values should be stripped before the computation proceeds. } \item{trim}{ The fraction (0 to 0.5) of pixel values to be trimmed from each end of their range, before the mean is computed. } \item{\dots}{ Ignored. } } \details{ These functions calculate the mean and median of the pixel values in the image \code{x}. An object of class \code{"im"} describes a pixel image. See \code{\link{im.object}}) for details of this class. The function \code{mean.im} is a method for the generic function \code{\link[base]{mean}} for the class \code{"im"}. Similarly \code{median.im} is a method for the generic \code{\link[stats]{median}}. If the image \code{x} is logical-valued, the mean value of \code{x} is the fraction of pixels that have the value \code{TRUE}. The median is not defined. If the image \code{x} is factor-valued, then the mean of \code{x} is the mean of the integer codes of the pixel values. The median is are not defined. Other mathematical operations on images are supported by \code{\link{Math.im}}, \code{\link{Summary.im}} and \code{\link{Complex.im}}. Other information about an image can be obtained using \code{\link{summary.im}} or \code{\link{quantile.im}}. } \value{ A single number. } \seealso{ \code{\link{Math.im}} for other operations. Generics and default methods: \code{\link[base]{mean}}, \code{\link[stats]{median}}. \code{\link{quantile.im}}, \code{\link{anyNA.im}}, \code{\link{im.object}}, \code{\link{summary.im}}. } \examples{ X <- as.im(function(x,y) {x^2}, unit.square()) mean(X) median(X) mean(X, trim=0.05) } \author{ \spatstatAuthors and Kassel Hingee. } \keyword{spatial} \keyword{methods} \keyword{univar} spatstat.geom/man/as.function.im.Rd0000644000176200001440000000156414611065345016753 0ustar liggesusers\name{as.function.im} \alias{as.function.im} \title{ Convert Pixel Image to Function of Coordinates } \description{ Converts a pixel image to a function of the \eqn{x} and \eqn{y} coordinates. } \usage{ \method{as.function}{im}(x, ...) } \arguments{ \item{x}{ Pixel image (object of class \code{"im"}). } \item{\dots}{ Ignored. } } \details{ This command converts a pixel image (object of class \code{"im"}) to a \code{function(x,y)} where the arguments \code{x} and \code{y} are (vectors of) spatial coordinates. This function returns the pixel values at the specified locations. } \value{ A function in the \R language, also belonging to the class \code{"funxy"}. } \author{ \adrian \rolf and \ege } \seealso{ \code{\link{[.im}} } \examples{ d <- setcov(square(1)) f <- as.function(d) f(0.1, 0.3) } \keyword{spatial} \keyword{manip} spatstat.geom/man/union.quad.Rd0000644000176200001440000000175014611065351016173 0ustar liggesusers\name{union.quad} \alias{union.quad} \title{Union of Data and Dummy Points} \description{ Combines the data and dummy points of a quadrature scheme into a single point pattern. } \usage{ union.quad(Q) } \arguments{ \item{Q}{A quadrature scheme (an object of class \code{"quad"}).} } \value{ A point pattern (of class \code{"ppp"}). } \details{ The argument \code{Q} should be a quadrature scheme (an object of class \code{"quad"}, see \code{\link{quad.object}} for details). This function combines the data and dummy points of \code{Q} into a single point pattern. If either the data or the dummy points are marked, the result is a marked point pattern. The function \code{\link{as.ppp}} will perform the same task. } \seealso{ \code{\link{quad.object}}, \code{\link{as.ppp}} } \examples{ Q <- quadscheme(simdat, default.dummy(simdat)) U <- union.quad(Q) # plot(U) # equivalent: U <- as.ppp(Q) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/hist.im.Rd0000644000176200001440000000464414611065346015476 0ustar liggesusers\name{hist.im} \alias{hist.im} \title{Histogram of Pixel Values in an Image} \description{ Computes and displays a histogram of the pixel values in a pixel image. The \code{hist} method for class \code{"im"}. } \usage{ \method{hist}{im}(x, \dots, probability=FALSE, xname) } \arguments{ \item{x}{A pixel image (object of class \code{"im"}).} \item{\dots}{Arguments passed to \code{\link{hist.default}} or \code{\link{barplot}}.} \item{probability}{Logical. If \code{TRUE}, the histogram will be normalised to give probabilities or probability densities. } \item{xname}{Optional. Character string to be used as the name of the dataset \code{x}. } } \details{ This function computes and (by default) displays a histogram of the pixel values in the image \code{x}. An object of class \code{"im"} describes a pixel image. See \code{\link{im.object}}) for details of this class. The function \code{hist.im} is a method for the generic function \code{\link{hist}} for the class \code{"im"}. Any arguments in \code{...} are passed to \code{\link{hist.default}} (for numeric valued images) or \code{\link{barplot}} (for factor or logical images). For example, such arguments control the axes, and may be used to suppress the plotting. } \value{ For numeric-valued images, an object of class \code{"histogram"} as returned by \code{\link[graphics:hist]{hist.default}}. This object can be plotted. For factor-valued or logical images, an object of class \code{"barplotdata"}, which can be plotted. This is a list with components called \code{counts} (contingency table of counts of the numbers of pixels taking each possible value), \code{probs} (corresponding relative frequencies) and \code{mids} (graphical \eqn{x}-coordinates of the midpoints of the bars in the barplot). } \seealso{ \code{\link[spatstat.explore]{spatialcdf}} for the cumulative distribution function of an image. \code{\link{hist}}, \code{\link{hist.default}}, \code{\link{barplot}}. For other statistical graphics such as Q-Q plots, use \code{X[]} to extract the pixel values of image \code{X}, and apply the usual statistical graphics commands. For information about pixel images see \code{\link{im.object}}, \code{\link{summary.im}}. } \examples{ X <- as.im(function(x,y) {x^2}, unit.square()) hist(X) hist(cut(X,3)) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/im.apply.Rd0000644000176200001440000000506114611065346015646 0ustar liggesusers\name{im.apply} \alias{im.apply} \title{ Apply Function Pixelwise to List of Images } \description{ Returns a pixel image obtained by applying a function to the values of corresponding pixels in several pixel images. } \usage{ im.apply(X, FUN, \dots, fun.handles.na=FALSE, check=TRUE) } \arguments{ \item{X}{ A list of pixel images (objects of class \code{"im"}). } \item{FUN}{ A function that can be applied to vectors, or a character string giving the name of such a function. } \item{\dots}{ Additional arguments to \code{FUN}. } \item{fun.handles.na}{ Logical value specifying what to do when the data include \code{NA} values. See Details. } \item{check}{ Logical value specifying whether to check that the images in \code{X} are compatible (for example that they have the same grid of pixel locations) and to convert them to compatible images if necessary. } } \details{ The argument \code{X} should be a list of pixel images (objects of class \code{"im"}). If the images do not have identical pixel grids, they will be converted to a common grid using \code{\link{harmonise.im}}. At each pixel location, the values of the images in \code{X} at that pixel will be extracted as a vector. The function \code{FUN} will be applied to this vector. The result (which should be a single value) becomes the pixel value of the resulting image. The argument \code{fun.handles.na} specifies what to do when some of the pixel values are \code{NA}. \itemize{ \item If \code{fun.handles.na=FALSE} (the default), the function \code{FUN} is never applied to data that include \code{NA} values; the result is defined to be \code{NA} whenever the data contain \code{NA}. \item If \code{fun.handles.na=TRUE}, the function \code{FUN} will be applied to all pixel data, including those which contain \code{NA} values. } } \value{ A pixel image (object of class \code{"im"}). } \seealso{ \code{\link{eval.im}} for algebraic operations with images. } \examples{ # list of two pixel images Y <- solapply(bei.extra, scaletointerval) plot(Y) im.apply(Y, max) im.apply(Y, sum) ## Example with incompatible patterns of NA values B <- owin(c(438, 666), c(80, 310)) Y[[1]][B] <- NA opa <- par(mfrow=c(2,2)) plot(Y[[1]]) plot(Y[[2]]) #' Default action: NA -> NA plot(im.apply(Y, mean)) #' Use NA handling in mean.default plot(im.apply(Y, mean, na.rm=TRUE, fun.handles.na=TRUE)) par(opa) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} \keyword{programming} spatstat.geom/man/is.marked.Rd0000644000176200001440000000253214611065346015772 0ustar liggesusers\name{is.marked} \alias{is.marked} \title{Test Whether Marks Are Present} \description{ Generic function to test whether a given object (usually a point pattern or something related to a point pattern) has ``marks'' attached to the points. } \usage{ is.marked(X, \dots) } \arguments{ \item{X}{ Object to be inspected } \item{\dots}{ Other arguments. } } \value{ Logical value, equal to \code{TRUE} if \code{X} is marked. } \details{ ``Marks'' are observations attached to each point of a point pattern. For example the \code{\link[spatstat.data]{longleaf}} dataset contains the locations of trees, each tree being marked by its diameter; the \code{\link[spatstat.data]{amacrine}} dataset gives the locations of cells of two types (on/off) and the type of cell may be regarded as a mark attached to the location of the cell. Other objects related to point patterns, such as point process models, may involve marked points. This function tests whether the object \code{X} contains or involves marked points. It is generic; methods are provided for point patterns (objects of class \code{"ppp"}) and point process models (objects of class \code{"ppm"}). } \seealso{ \code{\link{is.marked.ppp}}, \code{\link[spatstat.model]{is.marked.ppm}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/cbind.hyperframe.Rd0000644000176200001440000000327314611065345017337 0ustar liggesusers\name{cbind.hyperframe} \alias{cbind.hyperframe} \alias{rbind.hyperframe} \title{ Combine Hyperframes by Rows or by Columns } \description{ Methods for \code{cbind} and \code{rbind} for hyperframes. } \usage{ \method{cbind}{hyperframe}(...) \method{rbind}{hyperframe}(...) } \arguments{ \item{\dots}{ Any number of hyperframes (objects of class \code{\link{hyperframe}}). } } \details{ These are methods for \code{\link{cbind}} and \code{\link{rbind}} for hyperframes. Note that \emph{all} the arguments must be hyperframes (because of the peculiar dispatch rules of \code{\link{cbind}} and \code{\link{rbind}}). To combine a hyperframe with a data frame, one should either convert the data frame to a hyperframe using \code{\link{as.hyperframe}}, or explicitly invoke the function \code{cbind.hyperframe} or \code{rbind.hyperframe}. In other words: if \code{h} is a hyperframe and \code{d} is a data frame, the result of \code{cbind(h,d)} will be the same as \code{cbind(as.data.frame(h), d)}, so that all hypercolumns of \code{h} will be deleted (and a warning will be issued). To combine \code{h} with \code{d} so that all columns of \code{h} are retained, type either \code{cbind(h, as.hyperframe(d))} or \code{cbind.hyperframe(h,d)}. } \value{ Another hyperframe. } \author{ \spatstatAuthors. } \seealso{ \code{\link{hyperframe}}, \code{\link{as.hyperframe}} } \examples{ if(require(spatstat.random)) { lambda <- runif(5, min=10, max=30) X <- solapply(as.list(lambda), rpoispp) h <- hyperframe(lambda=lambda, X=X) g <- hyperframe(id=letters[1:5], Y=rev(X)) gh <- cbind(h, g) hh <- rbind(h[1:2, ], h[3:5,]) } } \keyword{spatial} \keyword{manip} spatstat.geom/man/shift.ppp.Rd0000644000176200001440000000465714611065350016035 0ustar liggesusers\name{shift.ppp} \alias{shift.ppp} \title{Apply Vector Translation To Point Pattern} \description{ Applies a vector shift to a point pattern. } \usage{ \method{shift}{ppp}(X, vec=c(0,0), \dots, origin=NULL) } \arguments{ \item{X}{Point pattern (object of class \code{"ppp"}).} \item{vec}{Vector of length 2 representing a translation.} \item{\dots}{Ignored} \item{origin}{ Location that will be shifted to the origin. Either a numeric vector of length 2 giving the location, or a point pattern containing only one point, or a list with two entries named \code{x} and \code{y}, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). } } \value{ Another point pattern (of class \code{"ppp"}) representing the result of applying the vector shift. } \details{ The point pattern, and its window, are translated by the vector \code{vec}. This is a method for the generic function \code{\link{shift}}. If \code{origin} is given, the argument \code{vec} will be ignored; instead the shift will be performed so that the specified geometric location is shifted to the coordinate origin \eqn{(0,0)}. The argument \code{origin} should be either a numeric vector of length 2 giving the spatial coordinates of a location, or one of the character strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} (partially matched). If \code{origin="centroid"} then the centroid of the window will be shifted to the origin. If \code{origin="midpoint"} then the centre of the bounding rectangle of the window will be shifted to the origin. If \code{origin="bottomleft"} then the bottom left corner of the bounding rectangle of the window will be shifted to the origin, and so on. } \seealso{ \code{\link{shift}}, \code{\link{shift.owin}}, \code{\link{periodify}}, \code{\link{rotate}}, \code{\link{affine}} } \examples{ X <- shift(cells, c(2,3)) # plot(X) # no discernible difference except coordinates are different plot(cells, pch=16) plot(shift(cells, c(0.03,0.03)), add=TRUE) shift(cells, origin="mid") } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/crossdist.psp.Rd0000644000176200001440000000476314611065345016742 0ustar liggesusers\name{crossdist.psp} \alias{crossdist.psp} \title{Pairwise distances between two different line segment patterns} \description{ Computes the distances between all pairs of line segments taken from two different line segment patterns. } \usage{ \method{crossdist}{psp}(X, Y, \dots, method="C", type="Hausdorff") } \arguments{ \item{X,Y}{ Line segment patterns (objects of class \code{"psp"}). } \item{\dots}{ Ignored. } \item{method}{String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. Usually not specified. } \item{type}{ Type of distance to be computed. Options are \code{"Hausdorff"} and \code{"separation"}. Partial matching is used. } } \value{ A matrix whose \code{[i,j]} entry is the distance from the \code{i}-th line segment in \code{X} to the \code{j}-th line segment in \code{Y}. } \details{ This is a method for the generic function \code{\link{crossdist}}. Given two line segment patterns, this function computes the distance from each line segment in the first pattern to each line segment in the second pattern, and returns a matrix containing these distances. The distances between line segments are measured in one of two ways: \itemize{ \item if \code{type="Hausdorff"}, distances are computed in the Hausdorff metric. The Hausdorff distance between two line segments is the \emph{maximum} distance from any point on one of the segments to the nearest point on the other segment. \item if \code{type="separation"}, distances are computed as the \emph{minimum} distance from a point on one line segment to a point on the other line segment. For example, line segments which cross over each other have separation zero. } The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted \R code only. If \code{method="C"} (the default) then compiled \code{C} code is used. The \code{C} code is several times faster. } \seealso{ \code{\link{pairdist}}, \code{\link{nndist}}, \code{\link[spatstat.explore]{Gest}} } \examples{ L1 <- psp(runif(5), runif(5), runif(5), runif(5), owin()) L2 <- psp(runif(10), runif(10), runif(10), runif(10), owin()) D <- crossdist(L1, L2) #result is a 5 x 10 matrix S <- crossdist(L1, L2, type="sep") } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/is.multitype.ppp.Rd0000644000176200001440000000423114611065346017357 0ustar liggesusers\name{is.multitype.ppp} \alias{is.multitype.ppp} \title{Test Whether A Point Pattern is Multitype} \description{ Tests whether a point pattern has ``marks'' attached to the points which classify the points into several types. } \usage{ \method{is.multitype}{ppp}(X, na.action="warn", \dots) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"}). } \item{na.action}{ String indicating what to do if \code{NA} values are encountered amongst the marks. Options are \code{"warn"}, \code{"fatal"} and \code{"ignore"}. } \item{\dots}{ Ignored. } } \value{ Logical value, equal to \code{TRUE} if \code{X} is a multitype point pattern. } \details{ ``Marks'' are observations attached to each point of a point pattern. For example the \code{\link[spatstat.data]{longleaf}} dataset contains the locations of trees, each tree being marked by its diameter; the \code{\link[spatstat.data]{amacrine}} dataset gives the locations of cells of two types (on/off) and the type of cell may be regarded as a mark attached to the location of the cell. This function tests whether the point pattern \code{X} contains or involves marked points, \bold{and} that the marks are a factor. It is a method for the generic function \code{\link{is.multitype}}. For example, the \code{\link[spatstat.data]{amacrine}} dataset is multitype (there are two types of cells, on and off), but the \code{\link[spatstat.data]{longleaf}} dataset is \emph{not} multitype (the marks are real numbers). The argument \code{na.action} determines what action will be taken if the point pattern has a vector of marks but some or all of the marks are \code{NA}. Options are \code{"fatal"} to cause a fatal error; \code{"warn"} to issue a warning and then return \code{TRUE}; and \code{"ignore"} to take no action except returning \code{TRUE}. } \seealso{ \code{\link{is.multitype}}, \code{\link[spatstat.model]{is.multitype.ppm}} } \examples{ is.multitype(cells) #FALSE - no marks is.multitype(longleaf) #FALSE - real valued marks is.multitype(amacrine) #TRUE } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.mask.Rd0000644000176200001440000001543214611065345015454 0ustar liggesusers\name{as.mask} \alias{as.mask} \title{Pixel Image Approximation of a Window} \description{ Obtain a discrete (pixel image) approximation of a given window } \usage{ as.mask(w, eps=NULL, dimyx=NULL, xy=NULL, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame")) } \arguments{ \item{w}{ A window (object of class \code{"owin"}) or data acceptable to \code{\link{as.owin}}. } \item{eps}{ (optional) width and height of pixels. A single number, or a numeric vector of length 2. } \item{dimyx}{ (optional) pixel array dimensions. A single integer, or an integer vector of length 2 giving dimensions in the \emph{y} and \emph{x} directions. } \item{xy}{ (optional) data containing pixel coordinates, such as a pixel image (object of class \code{"im"}), or a window of type \code{"mask"}. See Details. } \item{rule.eps}{ Character string (partially matched) specifying what to do when \code{eps} is not a divisor of the frame size. Ignored if \code{eps} is missing or null. See Details. } } \value{ A window (object of class \code{"owin"}) of type \code{"mask"} representing a binary pixel image. } \details{ A \sQuote{mask} is a spatial window that is represented by a pixel image with binary values. It is an object of class \code{"owin"} with type \code{"mask"}. This function \code{as.mask} creates a representation of any spatial window \code{w} as a mask. It generates a rectangular grid of locations in the plane, tests whether each of these locations lies inside \code{w}, and stores the results as a mask. The most common use of this function is to approximate the shape of a rectangular or polygonal window \code{w} by a mask, for computational purposes. In this case, we will usually want to have a very fine grid of pixels. This function can also be used to generate a coarsely-spaced grid of locations inside a window, for purposes such as subsampling and prediction. The argument \code{w} should be a window (object of class \code{"owin"}). If it is another kind of spatial data, then the window information will be extracted using \code{\link{as.owin}}. The grid spacing and location are controlled by the arguments \code{eps}, \code{dimyx} and \code{xy}, which are mutually incompatible. If \code{eps} is given, then it specifies the \emph{desired} grid spacing, that is, the desired size of the pixels. If \code{eps} is a single number, it specifies that the desired grid spacing is \code{eps} in both the \eqn{x} and \eqn{y} directions, that is, the desired pixels are squares with side length \code{eps}. If \code{eps} is a vector of length 2, it specifies that the desired grid spacing is \code{eps[1]} in the \eqn{x} direction and \code{eps[2]} in the \eqn{y} direction. That is, the desired pixels are rectangles of width \code{eps[1]} and height \code{eps[2]}. When \code{eps} is given, the argument \code{rule.eps} specifies what to do if pixels of the desired size would not fit exactly into the rectangular frame of \code{w}. \itemize{ \item if \code{rule.eps="adjust.eps"} (the default), the rectangular frame will remain unchanged, and the grid spacing (pixel size) \code{eps} will be reduced slightly so that an integer number of pixels fits exactly into the frame. \item if \code{rule.eps="grow.frame"}, the grid spacing (pixel size) \code{eps} will remain unchanged, and the rectangular frame will be expanded slightly so that it consists of an integer number of pixels in each direction. \item if \code{rule.eps="shrink.frame"}, the grid spacing (pixel size) \code{eps} will remain unchanged, and the rectangular frame will be contracted slightly so that it consists of an integer number of pixels in each direction. } If \code{dimyx} is given, then the pixel grid will be an \eqn{m \times n}{m * n} rectangular grid where \eqn{m, n} are given by \code{dimyx[2]}, \code{dimyx[1]} respectively. \bold{Warning:} \code{dimyx[1]} is the number of pixels in the \eqn{y} direction, and \code{dimyx[2]} is the number in the \eqn{x} direction. The grid spacing (pixel size) is determined by the frame size and the number of pixels. If \code{xy} is given, then this should be some kind of data specifing the coordinates of a pixel grid. It may be \itemize{ \item a list or structure containing elements \code{x} and \code{y} which are numeric vectors of equal length. These will be taken as \eqn{x} and \code{y} coordinates of the margins of the grid. The pixel coordinates will be generated from these two vectors. \item a pixel image (object of class \code{"im"}). \item a window (object of class \code{"owin"}) which is of type \code{"mask"} so that it contains pixel coordinates. } If \code{xy} is given and is either a pixel image or a mask, then \code{w} may be omitted, and the window information will be extracted from \code{xy}. If neither \code{eps} nor \code{dimyx} nor \code{xy} is given, the pixel raster dimensions are obtained from \code{\link{spatstat.options}("npixel")}. There is no inverse of this function. However, the function \code{\link{as.polygonal}} will compute a polygonal approximation of a binary mask. } \section{Discretisation rule}{ The rule used in \code{as.mask} is that a pixel is part of the discretised window if and only if the centre of the pixel falls in the original window. This is usually sufficient for most purposes, and is fast to compute. Other discretisation rules are possible; they are available using the function \code{\link{owin2mask}}. } \section{Converting a spatial pattern to a mask}{ If the intention is to discretise or pixellate a spatial pattern, such as a point pattern, line segment pattern or a linear network, then \code{as.mask} is not the appropriate function to use, because \code{as.mask} extracts only the window information and converts this window to a mask. To discretise a point pattern, use \code{\link{pixellate.ppp}}. To discretise a line segment pattern, use \code{\link{pixellate.psp}} or \code{\link{psp2mask}}. To discretise a linear network, use \code{\link[spatstat.linnet:methods.linnet]{pixellate.linnet}}. } \seealso{ \code{\link{owin2mask}}. \code{\link{owin.object}}, \code{\link{as.rectangle}}, \code{\link{as.polygonal}}, \code{\link{spatstat.options}} } \examples{ w <- owin(c(0,10),c(0,10), poly=list(x=c(1,2,3,2,1), y=c(2,3,4,6,7))) m <- as.mask(w) if(interactive()) { plot(w) plot(m) } x <- 1:9 y <- seq(0.25, 9.75, by=0.5) m <- as.mask(w, xy=list(x=x, y=y)) B <- square(1) as.mask(B, eps=0.3) as.mask(B, eps=0.3, rule.eps="g") as.mask(B, eps=0.3, rule.eps="s") } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/tiles.Rd0000644000176200001440000000160714611065351015233 0ustar liggesusers\name{tiles} \alias{tiles} \title{Extract List of Tiles in a Tessellation} \description{ Extracts a list of the tiles that make up a tessellation. } \usage{ tiles(x) } \arguments{ \item{x}{A tessellation (object of class \code{"tess"}).} } \details{ A tessellation is a collection of disjoint spatial regions (called \emph{tiles}) that fit together to form a larger spatial region. See \code{\link{tess}}. The tiles that make up the tessellation \code{x} are returned in a list. } \value{ A list of windows (objects of class \code{"owin"}). } \seealso{ \code{\link{tess}}, \code{\link{tilenames}}, \code{\link{tile.areas}}, \code{\link{tiles.empty}} } \examples{ A <- tess(xgrid=0:2,ygrid=0:2) tiles(A) v <- as.im(function(x,y){factor(round(x^2 + y^2))}, W=owin()) E <- tess(image=v) tiles(E) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/rQuasi.Rd0000644000176200001440000000233314611065350015353 0ustar liggesusers\name{rQuasi} \alias{rQuasi} \title{ Generate Quasirandom Point Pattern in Given Window } \description{ Generates a quasirandom pattern of points in any two-dimensional window. } \usage{ rQuasi(n, W, type = c("Halton", "Hammersley"), ...) } \arguments{ \item{n}{ Maximum number of points to be generated. } \item{W}{ Window (object of class \code{"owin"}) in which to generate the points. } \item{type}{ String identifying the quasirandom generator. } \item{\dots}{ Arguments passed to the quasirandom generator. } } \details{ This function generates a quasirandom point pattern, using the quasirandom sequence generator \code{\link{Halton}} or \code{\link{Hammersley}} as specified. If \code{W} is a rectangle, exactly \code{n} points will be generated. If \code{W} is not a rectangle, \code{n} points will be generated in the containing rectangle \code{as.rectangle(W)}, and only the points lying inside \code{W} will be retained. } \value{ Point pattern (object of class \code{"ppp"}) inside the window \code{W}. } \seealso{ \code{\link{Halton}} } \examples{ plot(rQuasi(256, letterR)) } \author{\adrian , \rolf and \ege. } \keyword{spatial} \keyword{datagen} spatstat.geom/man/bufftess.Rd0000644000176200001440000001015614643111575015740 0ustar liggesusers\name{bufftess} \alias{bufftess} \title{ Buffer Distance Tessellation } \description{ Constructs a spatial tessellation, composed of rings or buffers at specified distances away from the given spatial object. } \usage{ bufftess(X, breaks, W = Window(X), \dots, polygonal = TRUE) } \arguments{ \item{X}{ A spatial object in two dimensions, such as a point pattern (class \code{"ppp"}) or line segment pattern (class \code{"psp"}). } \item{breaks}{ Either a numeric vector specifying the cut points for the distance values, or a single integer specifying the number of cut points. } \item{W}{ Optional. Window (object of class \code{"owin"}) inside which the tessellation will be constructed. } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution when \code{polygonal=FALSE}, and optional arguments passed to \code{\link[base]{cut.default}} controlling the labelling of the distance bands. } \item{polygonal}{ Logical value specifying whether the tessellation should consist of polygonal tiles (\code{polygonal=TRUE}, the default) or should be constructed using a pixel image (\code{polygonal=FALSE}). } } \details{ This function divides space into tiles defined by distance from the object \code{X}. The result is a tessellation (object of class \code{"tess"}) that consists of concentric rings around \code{X}. The distance values which determine the tiles are specified by the argument \code{breaks}. \itemize{ \item If \code{breaks} is a vector of numerical values, then these values are taken to be the distances defining the tiles. The first tile is the region of space that lies at distances between \code{breaks[1]} and \code{breaks[2]} away from \code{X}; the second tile is the region lying at distances between \code{breaks[2]} and \code{breaks[3]} away from \code{X}; and so on. The number of tiles will be \code{length(breaks)-1}. \item If \code{breaks} is a single integer, it is interpreted as specifying the number of intervals between breakpoints. There will be \code{breaks+1} equally spaced break points, ranging from zero to the maximum achievable distance. The number of tiles will equal \code{breaks}. } The tessellation can be computed using either raster calculations or vector calculations. \itemize{ \item If \code{polygonal=TRUE} (the default), the tiles are computed as polygonal windows using vector geometry, and the result is a tessellation consisting of polygonal tiles. This calculation could be slow and could require substantial memory, but produces a geometrically accurate result. \item If \code{polygonal=FALSE}, the distance map of \code{X} is computed as a pixel image (\code{\link{distmap}}), then the distance values are divided into discrete bands using \code{\link{cut.im}}. The result is a tessellation specified by a pixel image. This computation is faster but less accurate. } } \value{ A tessellation (object of class \code{"tess"}). The result also has an attribute \code{breaks} which is the vector of distance breakpoints. } \author{ \spatstatAuthors. } \seealso{ Polygonal calculations are performed using \code{\link{dilation}} and \code{\link{setminus.owin}}. Pixel calculations are performed using \code{\link{distmap}} and \code{\link{cut.im}}. See \code{\link[spatstat.geom]{as.mask}} for details of arguments that control pixel resolution. For other kinds of tessellations, see \code{\link{tess}}, \code{\link{hextess}}, \code{\link{venn.tess}}, \code{\link{polartess}}, \code{\link{dirichlet}}, \code{\link{delaunay}}, \code{\link{quantess}}, \code{\link{quadrats}} and \code{\link[spatstat.random]{rpoislinetess}}. } \examples{ X <- cells[c(FALSE,FALSE,FALSE,TRUE)] if(interactive()) { b <- c(0, 0.05, 0.1, 0.15, 0.2, Inf) n <- 5 } else { ## simpler data for testing b <- c(0, 0.1, 0.2, Inf) n <- 3 } plot(bufftess(X, b), do.col=TRUE, col=1:n) } \keyword{spatial} \keyword{manip} \concept{Tessellation} spatstat.geom/man/as.function.owin.Rd0000644000176200001440000000225214611065345017315 0ustar liggesusers\name{as.function.owin} \alias{as.function.owin} \title{ Convert Window to Indicator Function } \description{ Converts a spatial window to a function of the \eqn{x} and \eqn{y} coordinates returning the value 1 inside the window and 0 outside. } \usage{ \method{as.function}{owin}(x, \dots) } \arguments{ \item{x}{ Pixel image (object of class \code{"owin"}). } \item{\dots}{ Ignored. } } \details{ This command converts a spatial window (object of class \code{"owin"}) to a \code{function(x,y)} where the arguments \code{x} and \code{y} are (vectors of) spatial coordinates. This is the indicator function of the window: it returns the value 1 for locations inside the window, and returns 0 for values outside the window. } \value{ A function in the \R language with arguments \code{x,y}. It also belongs to the class \code{"indicfun"} which has methods for \code{plot} and \code{print}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{as.im.owin}} } \examples{ W <- Window(humberside) f <- as.function(W) f f(5000, 4500) f(123456, 78910) X <- runifrect(5, Frame(humberside)) f(X) plot(f) } \keyword{spatial} \keyword{manip} spatstat.geom/man/quantilefun.im.Rd0000644000176200001440000000363614642117031017053 0ustar liggesusers\name{quantilefun.im} \alias{quantilefun.im} \title{ Quantile Function for Images } \description{ Return the inverse function of the cumulative distribution function of pixel values in an image. } \usage{ \method{quantilefun}{im}(x, \dots, type=1) } \arguments{ \item{x}{ Pixel image (object of class \code{"im"}). } \item{\dots}{ Other arguments passed to methods. } \item{type}{ Integer specifying the type of quantiles, as explained in \code{\link[stats]{quantile.default}}. Only types 1 and 2 are currently implemented. } } \details{ Whereas the command \code{\link[stats]{quantile}} calculates the quantiles of a dataset corresponding to desired probabilities \eqn{p}, the command \code{quantilefun} returns a function which can be used to compute any quantiles of the dataset. If \code{f <- quantilefun(x)} then \code{f} is a function such that \code{f(p)} is the quantile associated with any given probability \code{p}. For example \code{f(0.5)} is the median of the original data, and \code{f(0.99)} is the 99th percentile of the original data. If \code{x} is a pixel image (object of class \code{"im"}) then the pixel values of \code{x} will be extracted and the quantile function of the pixel values is constructed. } \value{ A function in the \R language. } \seealso{ \code{\link[spatstat.univar]{quantilefun}}, \code{\link[spatstat.univar]{ewcdf}}, \code{\link[spatstat.univar]{quantile.ewcdf}}, \code{\link[stats]{ecdf}}, \code{\link[stats]{quantile}} } \examples{ ## image data: terrain elevation Z <- bei.extra$elev if(require(spatstat.explore)) { FE <- spatialcdf(Z, normalise=TRUE) } else { FE <- ecdf(Z[]) } QE <- quantilefun(FE) QE(0.5) # median elevation if(interactive()) plot(QE, xlim=c(0,1), xlab="probability", ylab="quantile of elevation") } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{nonparametric} spatstat.geom/man/metric.object.Rd0000644000176200001440000000367214611065347016654 0ustar liggesusers\name{metric.object} \alias{metric.object} %DoNotExport \title{Distance Metric} \description{ An object of class \code{"metric"} defines a measure of distance between points, and supports many operations that involve distances. } \details{ A \sQuote{metric} \eqn{d} is a measure of distance between points that satisfies \enumerate{ \item \eqn{d(x,x) = 0} for any point \eqn{x}, \item \eqn{d(x,y) > 0} for any two distinct points \eqn{x} and \eqn{y} \item symmetry: \eqn{d(x,y) = d(y,x)} for any two points \eqn{x} and \eqn{y} \item triangle inequality: \eqn{d(x,y) \le d(x,z) + d(z,y)}{d(x,y) <= d(x,z) + d(z,y)} for any three points \eqn{x,y,z}. } The Euclidean distance between points is an example of a metric. An object of class \code{"metric"} is a structure that defines a metric and supports many computations that involve the metric. The internal structure of this object, and the mechanism for performing these computations, are under development. Objects of class \code{"metric"} are produced by the function \code{\link{convexmetric}} and possibly by other functions. There are methods for \code{print} and \code{summary} for the class \code{"metric"}. The \code{summary} method lists the operations that are supported by the metric. To perform distance calculations (for example, nearest-neighbour distances) using a desired metric instead of the Euclidean metric, first check whether the standard function for this purpose (for example \code{nndist.ppp}) has an argument named \code{metric}. If so, use the standard function and add the argument \code{metric}; if not, use the low-level function \code{\link{invoke.metric}}. } \seealso{ \code{\link{convexmetric}}, \code{\link{invoke.metric}} } \examples{ m <- convexmetric(square(c(-1,1))) summary(m) y <- nndist(cells, metric=m) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{attribute} spatstat.geom/man/corners.Rd0000644000176200001440000000173114611065345015567 0ustar liggesusers\name{corners} \alias{corners} \title{Corners of a rectangle} \description{ Returns the four corners of a rectangle } \usage{ corners(window) } \arguments{ \item{window}{A window. An object of class \code{\link{owin}}, or data in any format acceptable to \code{\link{as.owin}()}. } } \value{ A list with two components \code{x} and \code{y}, which are numeric vectors of length 4 giving the coordinates of the four corner points of the (bounding rectangle of the) window. } \details{ This trivial function is occasionally convenient. If \code{window} is of type \code{"rectangle"} this returns the four corners of the window itself; otherwise, it returns the corners of the bounding rectangle of the window. } \seealso{ \code{\link{quad.object}}, \code{\link{quadscheme}} } \examples{ w <- unit.square() corners(w) # returns list(x=c(0,1,0,1),y=c(0,0,1,1)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{utilities} spatstat.geom/man/hextess.Rd0000644000176200001440000000464114611065346015603 0ustar liggesusers\name{hextess} \alias{hexgrid} \alias{hextess} \title{ Hexagonal Grid or Tessellation } \description{ Construct a hexagonal grid of points, or a hexagonal tessellation. } \usage{ hexgrid(W, s, offset = c(0, 0), origin=NULL, trim = TRUE) hextess(W, s, offset = c(0, 0), origin=NULL, trim = TRUE) } \arguments{ \item{W}{ Window in which to construct the hexagonal grid or tessellation. An object of class \code{"owin"}. } \item{s}{ Side length of hexagons. A positive number. } \item{offset}{ Numeric vector of length 2 specifying a shift of the hexagonal grid. See Details. } \item{origin}{ Numeric vector of length 2 specifying the initial origin of the hexagonal grid, before the offset is applied. See Details. } \item{trim}{ Logical value indicating whether to restrict the result to the window \code{W}. See Details. } } \details{ \code{hexgrid} constructs a hexagonal grid of points on the window \code{W}. If \code{trim=TRUE} (the default), the grid is intersected with \code{W} so that all points lie inside \code{W}. If \code{trim=FALSE}, then we retain all grid points which are the centres of hexagons that intersect \code{W}. \code{hextess} constructs a tessellation of hexagons on the window \code{W}. If \code{trim=TRUE} (the default), the tessellation is restricted to the interior of \code{W}, so that there will be some fragmentary hexagons near the boundary of \code{W}. If \code{trim=FALSE}, the tessellation consists of all hexagons which intersect \code{W}. The points of \code{hexgrid(...)} are the centres of the tiles of \code{hextess(...)} in the same order. In the initial position of the grid or tessellation, one of the grid points (tile centres) is placed at the \code{origin}, which defaults to the midpoint of the bounding rectangle of \code{W}. The grid can be shifted relative to this origin by specifing the \code{offset}. } \value{ The value of \code{hexgrid} is a point pattern (object of class \code{"ppp"}). The value of \code{hextess} is a tessellation (object of class \code{"tess"}). } \seealso{ \code{\link{tess}} \code{\link{hexagon}} } \examples{ if(interactive()) { W <- Window(chorley) s <- 0.7 } else { W <- letterR s <- 0.3 } plot(hextess(W, s)) plot(hexgrid(W, s), add=TRUE) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{datagen} \concept{Tessellation} spatstat.geom/man/selfcrossing.psp.Rd0000644000176200001440000000200014611065350017400 0ustar liggesusers\name{selfcrossing.psp} \alias{selfcrossing.psp} \title{Crossing Points in a Line Segment Pattern} \description{ Finds any crossing points between the line segments in a line segment pattern. } \usage{ selfcrossing.psp(A) } \arguments{ \item{A}{ Line segment pattern (object of class \code{"psp"}). } } \value{ Point pattern (object of class \code{"ppp"}). } \details{ This function finds any crossing points between different line segments in the line segment pattern \code{A}. A crossing point occurs whenever one of the line segments in \code{A} intersects another line segment in \code{A}, at a nonzero angle of intersection. } \seealso{ \code{\link{crossing.psp}}, \code{\link{psp.object}}, \code{\link{ppp.object}}. } \examples{ a <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) plot(a, col="green", main="selfcrossing.psp") P <- selfcrossing.psp(a) plot(P, add=TRUE, col="red") } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.data.frame.tess.Rd0000644000176200001440000000332414611065345017475 0ustar liggesusers\name{as.data.frame.tess} \alias{as.data.frame.tess} \title{Convert Tessellation to Data Frame} \description{ Converts a spatial tessellation object to a data frame. } \usage{ \method{as.data.frame}{tess}(x, \dots) } \arguments{ \item{x}{ Tessellation (object of class \code{"tess"}). } \item{\dots}{Further arguments passed to \code{\link{as.data.frame.owin}} or \code{\link{as.data.frame.im}} and ultimately to \code{\link[base:as.data.frame]{as.data.frame.default}} to determine the row names and other features. } } \details{ This function converts the tessellation \code{x} to a data frame. If \code{x} is a pixel image tessellation (a pixel image with factor values specifying the tile membership of each pixel) then this pixel image is converted to a data frame by \code{\link{as.data.frame.im}}. The result is a data frame with columns \code{x} and \code{y} giving the pixel coordinates, and \code{Tile} identifying the tile containing the pixel. If \code{x} is a tessellation consisting of a rectangular grid of tiles or a list of polygonal tiles, then each tile is converted to a data frame by \code{\link{as.data.frame.owin}}, and these data frames are joined together, yielding a single large data frame containing columns \code{x}, \code{y} giving the coordinates of vertices of the polygons, and \code{Tile} identifying the tile. } \value{ A data frame with columns named \code{x}, \code{y}, \code{Tile}, and possibly other columns. } \author{ \spatstatAuthors. } \seealso{ \code{\link{as.data.frame.owin}}, \code{\link{as.data.frame.im}} } \examples{ Z <- as.data.frame(dirichlet(cells)) head(Z, 10) } \keyword{spatial} \keyword{methods} \concept{Tessellation} spatstat.geom/man/Extract.layered.Rd0000644000176200001440000000472114611065346017155 0ustar liggesusers\name{Extract.layered} \alias{[.layered} \alias{[<-.layered} \alias{[[<-.layered} \title{Extract or Replace Subset of a Layered Object} \description{ Extract or replace some or all of the layers of a layered object, or extract a spatial subset of each layer. } \usage{ \method{[}{layered}(x, i, j, drop=FALSE, ...) \method{[}{layered}(x, i) <- value \method{[[}{layered}(x, i) <- value } \arguments{ \item{x}{ A layered object (class \code{"layered"}). } \item{i}{ Subset index for the list of layers. A logical vector, integer vector or character vector specifying which layers are to be extracted or replaced. } \item{j}{ Subset index to be applied to the data in each layer. Typically a spatial window (class \code{"owin"}). } \item{drop}{ Logical. If \code{i} specifies only a single layer and \code{drop=TRUE}, then the contents of this layer will be returned. } \item{\dots}{ Additional arguments, passed to other subset methods if the subset index is a window. } \item{value}{List of objects which shall replace the designated subset, or an object which shall replace the designated element. } } \value{ Usually an object of class \code{"layered"}. } \details{ A layered object represents data that should be plotted in successive layers, for example, a background and a foreground. See \code{\link{layered}}. The function \code{[.layered} extracts a designated subset of a layered object. It is a method for \code{\link{[}} for the class \code{"layered"}. The functions \code{[<-.layered} and \code{[[<-.layered} replace a designated subset or designated entry of the object by new values. They are methods for \code{\link{[<-}} and \code{\link{[[<-}} for the \code{"layered"} class. The index \code{i} specifies which layers will be retained. It should be a valid subset index for the list of layers. The index \code{j} will be applied to each layer. It is typically a spatial window (class \code{"owin"}) so that each of the layers will be restricted to the same spatial region. Alternatively \code{j} may be any subset index which is permissible for the \code{"["} method for each of the layers. } \seealso{ \code{\link{layered}} } \examples{ D <- distmap(cells) L <- layered(D, cells, plotargs=list(list(ribbon=FALSE), list(pch=16))) L[-2] L[, square(0.5)] L[[3]] <- japanesepines L } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/owin.object.Rd0000644000176200001440000000711014643111575016334 0ustar liggesusers\name{owin.object} \alias{owin.object} %DoNotExport \title{Class owin} \description{ A class \code{owin} to define the ``observation window'' of a point pattern } \details{ In the \pkg{spatstat} library, a point pattern dataset must include information about the window or region in which the pattern was observed. A window is described by an object of class \code{"owin"}. Windows of arbitrary shape are supported. An object of class \code{"owin"} has one of three types: \tabular{ll}{ \code{"rectangle"}: \tab a rectangle in the two-dimensional plane with edges parallel to the axes \cr \code{"polygonal"}: \tab a region whose boundary is a polygon or several polygons. The region may have holes and may consist of several disconnected pieces. \cr \code{"mask"}: \tab a binary image (a logical matrix) set to \code{TRUE} for pixels inside the window and \code{FALSE} outside the window. } Objects of class \code{"owin"} may be created by the function \code{\link{owin}} and converted from other types of data by the function \code{\link{as.owin}}. They may be manipulated by the functions \code{\link{as.rectangle}}, \code{\link[spatstat.geom]{as.mask}}, \code{\link{complement.owin}}, \code{\link{rotate}}, \code{\link{shift}}, \code{\link{affine}}, \code{\link{erosion}}, \code{\link{dilation}}, \code{\link{opening}} and \code{\link{closing}}. Geometrical calculations available for windows include \code{\link{area.owin}}, \code{\link{perimeter}}, \code{\link{diameter.owin}}, \code{\link{boundingbox}}, \code{\link{eroded.areas}}, \code{\link{bdist.points}}, \code{\link{bdist.pixels}}, and \code{even.breaks.owin}. The mapping between continuous coordinates and pixel raster indices is facilitated by the functions \code{\link{raster.x}}, \code{\link{raster.y}} and \code{\link{nearest.raster.point}}. There is a \code{plot} method for window objects, \code{\link{plot.owin}}. This may be useful if you wish to plot a point pattern's window without the points for graphical purposes. There are also methods for \code{summary} and \code{print}. } \seealso{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{as.rectangle}}, \code{\link[spatstat.geom]{as.mask}}, \code{\link{summary.owin}}, \code{\link{print.owin}}, \code{\link{complement.owin}}, \code{\link{erosion}}, \code{\link{dilation}}, \code{\link{opening}}, \code{\link{closing}}, \code{\link{affine.owin}}, \code{\link{shift.owin}}, \code{\link{rotate.owin}}, \code{\link{raster.x}}, \code{\link{raster.y}}, \code{\link{nearest.raster.point}}, \code{\link{plot.owin}}, \code{\link{area.owin}}, \code{\link{boundingbox}}, \code{\link{diameter}}, \code{\link{eroded.areas}}, \code{\link{bdist.points}}, \code{\link{bdist.pixels}} } \section{Warnings}{ In a window of type \code{"mask"}, the row index corresponds to increasing \eqn{y} coordinate, and the column index corresponds to increasing \eqn{x} coordinate. } \examples{ w <- owin() w <- owin(c(0,1), c(0,1)) # the unit square w <- owin(c(0,1), c(0,2)) if(FALSE) { plot(w) # plots edges of a box 1 unit x 2 units v <- locator() # click on points in the plot window # to be the vertices of a polygon # traversed in anticlockwise order u <- owin(c(0,1), c(0,2), poly=v) plot(u) # plots polygonal boundary using polygon() plot(as.mask(u, eps=0.02)) # plots discrete pixel approximation to polygon } } \author{\adrian and \rolf } \keyword{spatial} \keyword{attribute} spatstat.geom/man/summary.anylist.Rd0000644000176200001440000000156014611065350017267 0ustar liggesusers\name{summary.anylist} \alias{summary.anylist} \title{Summary of a List of Things} \description{ Prints a useful summary of each item in a list of things. } \usage{ \method{summary}{anylist}(object, \dots) } \arguments{ \item{object}{ An object of class \code{"anylist"}. } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link{summary}}. An object of the class \code{"anylist"} is effectively a list of things which are intended to be treated in a similar way. See \code{\link{anylist}}. This function extracts a useful summary of each of the items in the list. } \seealso{ \code{\link{anylist}}, \code{\link{summary}}, \code{\link{plot.anylist}} } \examples{ x <- anylist(A=runif(10), B=runif(10), C=runif(10)) summary(x) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/is.convex.Rd0000644000176200001440000000201214611065346016022 0ustar liggesusers\name{is.convex} \alias{is.convex} \title{Test Whether a Window is Convex} \description{ Determines whether a window is convex. } \usage{ is.convex(x) } \arguments{ \item{x}{ Window (object of class \code{"owin"}). } } \value{ Logical value, equal to \code{TRUE} if \code{x} is convex. } \details{ If \code{x} is a rectangle, the result is TRUE. If \code{x} is polygonal, the result is TRUE if \code{x} consists of a single polygon and this polygon is equal to the minimal convex hull of its vertices computed by \code{\link[grDevices]{chull}}. If \code{x} is a mask, the algorithm first extracts all boundary pixels of \code{x} using \code{\link{vertices}}. Then it computes the (polygonal) convex hull \eqn{K} of the boundary pixels. The result is TRUE if every boundary pixel lies within one pixel diameter of an edge of \eqn{K}. } \seealso{ \code{\link{owin}}, \code{\link{convexhull.xy}}, \code{\link{vertices}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/superimpose.Rd0000644000176200001440000001667114611065350016474 0ustar liggesusers\name{superimpose} \alias{superimpose} \alias{superimpose.ppp} \alias{superimpose.splitppp} \alias{superimpose.ppplist} \alias{superimpose.psp} \alias{superimpose.default} \title{Superimpose Several Geometric Patterns} \description{ Superimpose any number of point patterns or line segment patterns. } \usage{ superimpose(\dots) \method{superimpose}{ppp}(\dots, W=NULL, check=TRUE) \method{superimpose}{psp}(\dots, W=NULL, check=TRUE) \method{superimpose}{splitppp}(\dots, W=NULL, check=TRUE) \method{superimpose}{ppplist}(\dots, W=NULL, check=TRUE) \method{superimpose}{default}(\dots) } \arguments{ \item{\dots}{ Any number of arguments, each of which represents either a point pattern or a line segment pattern or a list of point patterns. } \item{W}{ Optional. Data determining the window for the resulting pattern. Either a window (object of class \code{"owin"}, or something acceptable to \code{\link{as.owin}}), or a function which returns a window, or one of the strings \code{"convex"}, \code{"rectangle"}, \code{"bbox"} or \code{"none"}. } \item{check}{ Logical value (passed to \code{\link{ppp}} or \code{\link{psp}} as appropriate) determining whether to check the geometrical validity of the resulting pattern. } } \value{ For \code{superimpose.ppp}, a point pattern (object of class \code{"ppp"}). For \code{superimpose.default}, either a point pattern (object of class \code{"ppp"}) or a \code{list(x,y)}. For \code{superimpose.psp}, a line segment pattern (object of class \code{"psp"}). } \details{ This function is used to superimpose several geometric patterns of the same kind, producing a single pattern of the same kind. The function \code{superimpose} is generic, with methods for the class \code{ppp} of point patterns, the class \code{psp} of line segment patterns, and a default method. There is also a method for \code{lpp}, described separately in \code{superimpose.lpp}. The dispatch to a method is initially determined by the class of the \emph{first} argument in \code{\dots}. \itemize{ \item \code{default}: If the first argument is \emph{not} an object of class \code{ppp} or \code{psp}, then the default method \code{superimpose.default} is executed. This checks the class of all arguments, and dispatches to the appropriate method. Arguments of class \code{ppplist} can be handled. \item \code{ppp}: If the first \code{\dots} argument is an object of class \code{ppp} then the method \code{superimpose.ppp} is executed. All arguments in \code{\dots} must be either \code{ppp} objects or lists with components \code{x} and \code{y}. The result will be an object of class \code{ppp}. \item psp: If the first \code{\dots} argument is an object of class \code{psp} then the \code{psp} method is dispatched and all \code{\dots} arguments must be \code{psp} objects. The result is a \code{psp} object. } The patterns are \emph{not} required to have the same window of observation. The window for the superimposed pattern is controlled by the argument \code{W}. \itemize{ \item If \code{W} is a window (object of class \code{"W"} or something acceptable to \code{\link{as.owin}}) then this determines the window for the superimposed pattern. \item If \code{W} is \code{NULL}, or the character string \code{"none"}, then windows are extracted from the geometric patterns, as follows. For \code{superimpose.psp}, all arguments \code{\dots} are line segment patterns (objects of class \code{"psp"}); their observation windows are extracted; the union of these windows is computed; and this union is taken to be the window for the superimposed pattern. For \code{superimpose.ppp} and \code{superimpose.default}, the arguments \code{\dots} are inspected, and any arguments which are point patterns (objects of class \code{"ppp"}) are selected; their observation windows are extracted, and the union of these windows is taken to be the window for the superimposed point pattern. For \code{superimpose.default} if none of the arguments is of class \code{"ppp"} then no window is computed and the result of \code{superimpose} is a \code{list(x,y)}. \item If \code{W} is one of the strings \code{"convex"}, \code{"rectangle"} or \code{"bbox"} then a window for the superimposed pattern is computed from the coordinates of the points or the line segments as follows. \describe{ \item{\code{"bbox"}:}{the bounding box of the points or line segments (see \code{\link{bounding.box.xy}});} \item{\code{"convex"}:}{the Ripley-Rasson estimator of a convex window (see \code{\link{ripras}});} \item{\code{"rectangle"}:}{the Ripley-Rasson estimator of a rectangular window (using \code{\link{ripras}} with argument \code{shape="rectangle"}).} } \item If \code{W} is a function, then this function is used to compute a window for the superimposed pattern from the coordinates of the points or the line segments. The function should accept input of the form \code{list(x,y)} and is expected to return an object of class \code{"owin"}. Examples of such functions are \code{\link{ripras}} and \code{\link{bounding.box.xy}}. } The arguments \code{\dots} may be \emph{marked} patterns. The marks of each component pattern must have the same format. Numeric and character marks may be ``mixed''. If there is such mixing then the numeric marks are coerced to character in the combining process. If the mark structures are all data frames, then these data frames must have the same number of columns and identical column names. If the arguments \code{\dots} are given in the form \code{name=value}, then the \code{name}s will be used as an extra column of marks attached to the elements of the corresponding patterns. } \seealso{ \code{\link{concatxy}}, \code{\link{quadscheme}}. } \examples{ # superimposing point patterns p1 <- runifrect(30) p2 <- runifrect(42) s1 <- superimpose(p1,p2) # Unmarked pattern. p3 <- list(x=rnorm(20),y=rnorm(20)) s2 <- superimpose(p3,p2,p1) # Default method gets called. s2a <- superimpose(p1,p2,p3) # Same as s2 except for order of points. s3 <- superimpose(clyde=p1,irving=p2) # Marked pattern; marks a factor # with levels "clyde" and "irving"; # warning given. marks(p1) <- factor(sample(LETTERS[1:3],30,TRUE)) marks(p2) <- factor(sample(LETTERS[1:3],42,TRUE)) s5 <- superimpose(clyde=p1,irving=p2) # Marked pattern with extra column marks(p2) <- data.frame(a=marks(p2),b=runif(42)) s6 <- try(superimpose(p1,p2)) # Gives an error. marks(p1) <- data.frame(a=marks(p1),b=1:30) s7 <- superimpose(p1,p2) # O.K. # how to make a 2-type point pattern with types "a" and "b" u <- superimpose(a = runifrect(10), b = runifrect(20)) # how to make a 2-type point pattern with types 1 and 2 u <- superimpose("1" = runifrect(10), "2" = runifrect(20)) # superimposing line segment patterns X <- as.psp(matrix(runif(20), 5, 4), window=owin()) Y <- as.psp(matrix(runif(40), 10, 4), window=owin()) Z <- superimpose(X, Y) # being unreasonable \dontrun{ if(FALSE) { crud <- try(superimpose(p1,p2,X,Y)) # Gives an error, of course! } } } \author{ \adrian and \rolf. } \keyword{spatial} \keyword{manip} spatstat.geom/man/affine.im.Rd0000644000176200001440000000301414643111575015746 0ustar liggesusers\name{affine.im} \alias{affine.im} \title{Apply Affine Transformation To Pixel Image} \description{ Applies any affine transformation of the plane (linear transformation plus vector shift) to a pixel image. } \usage{ \method{affine}{im}(X, mat=diag(c(1,1)), vec=c(0,0), \dots) } \arguments{ \item{X}{Pixel image (object of class \code{"im"}).} \item{mat}{Matrix representing a linear transformation.} \item{vec}{Vector of length 2 representing a translation.} \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution of the transformed image. } } \value{ Another pixel image (of class \code{"im"}) representing the result of applying the affine transformation. } \details{ The image is subjected first to the linear transformation represented by \code{mat} (multiplying on the left by \code{mat}), and then the result is translated by the vector \code{vec}. The argument \code{mat} must be a nonsingular \eqn{2 \times 2}{2 * 2} matrix. This is a method for the generic function \code{\link{affine}}. } \seealso{ \code{\link{affine}}, \code{\link{affine.ppp}}, \code{\link{affine.psp}}, \code{\link{affine.owin}}, \code{\link{rotate}}, \code{\link{shift}} } \examples{ X <- setcov(owin()) stretch <- diag(c(2,3)) Y <- affine(X, mat=stretch) shear <- matrix(c(1,0,0.6,1),ncol=2, nrow=2) Z <- affine(X, mat=shear) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} \concept{Geometrical transformations} spatstat.geom/man/is.lpp.Rd0000644000176200001440000000111514611065351015312 0ustar liggesusers\name{is.lpp} \alias{is.lpp} \title{Test Whether An Object Is A Point Pattern on a Linear Network} \description{ Checks whether its argument is a point pattern on a linear network (object of class \code{"lpp"}). } \usage{ is.lpp(x) } \arguments{ \item{x}{Any object.} } \details{ This function tests whether the object \code{x} is a point pattern object of class \code{"lpp"}. } \value{ \code{TRUE} if \code{x} is a point pattern of class \code{"lpp"}, otherwise \code{FALSE}. } \author{ \adrian and \rolf. } \keyword{spatial} \keyword{manip} \concept{Linear network} spatstat.geom/man/by.ppp.Rd0000644000176200001440000000546514611065345015334 0ustar liggesusers\name{by.ppp} \alias{by.ppp} \title{Apply a Function to a Point Pattern Broken Down by Factor} \description{ Splits a point pattern into sub-patterns, and applies the function to each sub-pattern. } \usage{ \method{by}{ppp}(data, INDICES=marks(data), FUN, ...) } \arguments{ \item{data}{Point pattern (object of class \code{"ppp"}).} \item{INDICES}{Grouping variable. Either a factor, a pixel image with factor values, or a tessellation.} \item{FUN}{Function to be applied to subsets of \code{data}.} \item{\dots}{Additional arguments to \code{FUN}.} } \details{ This is a method for the generic function \code{\link{by}} for point patterns (class \code{"ppp"}). The point pattern \code{data} is first divided into subsets according to \code{INDICES}. Then the function \code{FUN} is applied to each subset. The results of each computation are returned in a list. The argument \code{INDICES} may be \itemize{ \item a factor, of length equal to the number of points in \code{data}. The levels of \code{INDICES} determine the destination of each point in \code{data}. The \code{i}th point of \code{data} will be placed in the sub-pattern \code{split.ppp(data)$l} where \code{l = f[i]}. \item a pixel image (object of class \code{"im"}) with factor values. The pixel value of \code{INDICES} at each point of \code{data} will be used as the classifying variable. \item a tessellation (object of class \code{"tess"}). Each point of \code{data} will be classified according to the tile of the tessellation into which it falls. } If \code{INDICES} is missing, then \code{data} must be a multitype point pattern (a marked point pattern whose marks vector is a factor). Then the effect is that the points of each type are separated into different point patterns. } \value{ A list (also of class \code{"anylist"} or \code{"solist"} as appropriate) containing the results returned from \code{FUN} for each of the subpatterns. } \seealso{ \code{\link{ppp}}, \code{\link{split.ppp}}, \code{\link{cut.ppp}}, \code{\link{tess}}, \code{\link{im}}. } \examples{ # multitype point pattern, broken down by type by(amacrine, FUN=minnndist) by(amacrine, FUN=function(x) { intensity(unmark(x)) }) if(require(spatstat.explore)) { # how to pass additional arguments to FUN by(amacrine, FUN=clarkevans, correction=c("Donnelly","cdf")) } # point pattern broken down by tessellation data(swedishpines) tes <- quadrats(swedishpines, 4,4) ## compute minimum nearest neighbour distance for points in each tile B <- by(swedishpines, tes, minnndist) if(require(spatstat.explore)) { B <- by(swedishpines, tes, clarkevans, correction="Donnelly") simplify2array(B) } } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} \keyword{manip} spatstat.geom/man/erosionAny.Rd0000644000176200001440000000362314611065346016245 0ustar liggesusers\name{erosionAny} \alias{erosionAny} \alias{\%(-)\%} %DoNotExport %NAMESPACE export("%(-)%") \title{Morphological Erosion of Windows} \description{ Compute the morphological erosion of one spatial window by another. } \usage{ erosionAny(A, B) A \%(-)\% B } \arguments{ \item{A,B}{ Windows (objects of class \code{"owin"}). } } \value{ Another window (object of class \code{"owin"}). } \details{ The operator \code{A \%(-)\% B} and function \code{erosionAny(A,B)} are synonymous: they both compute the morphological erosion of the window \code{A} by the window \code{B}. The morphological erosion \eqn{A \ominus B}{A \%(-)\% B} of region \eqn{A} by region \eqn{B} is the spatial region consisting of all vectors \eqn{z} such that, when \eqn{B} is shifted by the vector \eqn{z}, the result is a subset of \eqn{A}. Equivalently \deqn{ A \ominus B = ((A^c \oplus (-B))^c }{ (A^c \%+\% (-B))^c } where \eqn{\oplus}{\%+\%} is the Minkowski sum, \eqn{A^c} denotes the set complement, and \eqn{(-B)} is the reflection of \eqn{B} through the origin, consisting of all vectors \eqn{-b} where \eqn{b} is a point in \eqn{B}. If \code{B} is a disc of radius \code{r}, then \code{erosionAny(A, B)} is equivalent to \code{erosion(A, r)}. See \code{\link{erosion}}. The algorithm currently computes the result as a polygonal window using the \pkg{polyclip} library. It will be quite slow if applied to binary mask windows. } \seealso{ \code{\link{erosion}}, \code{\link{MinkowskiSum}} } \examples{ B <- square(c(-0.1, 0.1)) RminusB <- letterR \%(-)\% B FR <- grow.rectangle(Frame(letterR), 0.3) plot(FR, main="", type="n") plot(letterR, add=TRUE, lwd=2, hatch=TRUE, box=FALSE) plot(RminusB, add=TRUE, col="blue", box=FALSE) plot(shift(B, vec=c(3.49, 2.98)), add=TRUE, border="red", lwd=2) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{math} spatstat.geom/man/is.connected.ppp.Rd0000644000176200001440000000255414611065346017273 0ustar liggesusers\name{is.connected.ppp} \Rdversion{1.1} \alias{is.connected.ppp} \title{ Determine Whether a Point Pattern is Connected } \description{ Determine whether a point pattern is topologically connected when all pairs of points closer than a threshold distance are joined. } \usage{ \method{is.connected}{ppp}(X, R, \dots) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"}). } \item{R}{ Threshold distance. Pairs of points closer than \code{R} units apart will be joined together. } \item{\dots}{ Ignored. } } \details{ The function \code{is.connected} is generic. This is the method for point patterns (objects of class \code{"ppp"}). The point pattern \code{X} is first converted into an abstract graph by joining every pair of points that lie closer than \code{R} units apart. Then the algorithm determines whether this graph is connected. That is, the result of \code{is.connected(X)} is \code{TRUE} if any point in \code{X} can be reached from any other point, by a series of steps between points of \code{X}, each step being shorter than \code{R} units in length. } \value{ A logical value. } \seealso{ \code{\link{is.connected}}, \code{\link{connected.ppp}}. } \examples{ is.connected(redwoodfull, 0.1) is.connected(redwoodfull, 0.2) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{math} spatstat.geom/man/plot.colourmap.Rd0000644000176200001440000001113414721742045017071 0ustar liggesusers\name{plot.colourmap} \alias{plot.colourmap} \title{Plot a Colour Map} \description{ Displays a colour map as a colour ribbon } \usage{ \method{plot}{colourmap}(x, ..., main, xlim = NULL, ylim = NULL, vertical = FALSE, axis = TRUE, side = if(vertical) "right" else "bottom", labelmap=NULL, gap=0.25, add=FALSE, increasing=NULL, nticks=5, box=NULL) } \arguments{ \item{x}{Colour map to be plotted. An object of class \code{"colourmap"}.} \item{\dots}{ Graphical arguments passed to \code{\link{image.default}} or \code{\link{axis}}. } \item{main}{Main title for plot. A character string.} \item{xlim}{ Optional range of \code{x} values for the location of the colour ribbon. } \item{ylim}{ Optional range of \code{y} values for the location of the colour ribbon. } \item{vertical}{ Logical flag determining whether the colour ribbon is plotted as a horizontal strip (\code{FALSE}) or a vertical strip (\code{TRUE}). } \item{axis}{ Logical value determining whether an axis should be plotted showing the numerical values that are mapped to the colours. } \item{side}{ One of the character strings \code{"bottom"}, \code{"left"}, \code{"top"} or \code{"right"}, or one of the integers from 1 to 4, specifying the position of the axis tick marks and labels, if \code{axis=TRUE}. } \item{labelmap}{ Function. If this is present, then the labels on the plot, which indicate the input values corresponding to particular colours, will be transformed by \code{labelmap} before being displayed on the plot. Typically used to simplify or shorten the labels on the plot. } \item{gap}{ Distance between separate blocks of colour, as a fraction of the width of one block, if the colourmap is discrete. } \item{add}{ Logical value indicating whether to add the colourmap to the existing plot (\code{add=TRUE}), or to start a new plot (\code{add=FALSE}, the default). } \item{increasing}{ Logical value indicating whether to display the colour map in increasing order. See Details. } \item{nticks}{ Optional. Integer specifying the approximate number of tick marks (representing different values of the numerical input) that should be drawn next to the colour map. Applies only when the colour map inputs are numeric values. } \item{box}{ Optional. Logical value specifying whether to draw a black box around the colour ribbon. Default is \code{box=FALSE} when plotting separate blocks of colour (i.e. when the colourmap is discrete and \code{gap > 0}) and \code{box=TRUE} otherwise. } } \details{ This is the plot method for the class \code{"colourmap"}. An object of this class (created by the function \code{\link{colourmap}}) represents a colour map or colour lookup table associating colours with each data value. The command \code{plot.colourmap} displays the colour map as a colour ribbon or as a colour legend (a sequence of blocks of colour). This plot can be useful on its own to inspect the colour map. If the domain of the colourmap is an interval of real numbers, the colourmap is displayed as a continuous ribbon of colour. If the domain of the colourmap is a finite set of inputs, the colours are displayed as separate blocks of colour. The separation between blocks is equal to \code{gap} times the width of one block. To annotate an existing plot with an explanatory colour ribbon or colour legend, specify \code{add=TRUE} and use the arguments \code{xlim} and/or \code{ylim} to control the physical position of the ribbon on the plot. Labels explaining the colour map are drawn by \code{\link[graphics]{axis}} and can be modified by specifying arguments that will be passed to this function. The argument \code{increasing} indicates whether the colourmap should be displayed so that the input values are increasing with the spatial coordinate: that is, increasing from left to right (if \code{vertical=FALSE}) or increasing from bottom to top (if \code{vertical=TRUE}). If \code{increasing=FALSE}, this ordering will be reversed. The default is \code{increasing=TRUE} in all cases except when \code{vertical=TRUE} and the domain of the colourmap is a finite set of discrete inputs. } \value{ None. } \seealso{\code{\link{colourmap}}} \examples{ co <- colourmap(rainbow(100), breaks=seq(-1,1,length=101)) plot(co) plot(co, col.ticks="pink") ca <- colourmap(rainbow(8), inputs=letters[1:8]) plot(ca, vertical=TRUE) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{color} \keyword{hplot} spatstat.geom/man/append.psp.Rd0000644000176200001440000000226714611065345016171 0ustar liggesusers\name{append.psp} \alias{append.psp} \title{Combine Two Line Segment Patterns} \description{ Combine two line segment patterns into a single pattern. } \usage{ append.psp(A, B) } \arguments{ \item{A,B}{ Line segment patterns (objects of class \code{"psp"}). } } \value{ Another line segment pattern (object of class \code{"psp"}). } \details{ This function is used to superimpose two line segment patterns \code{A} and \code{B}. The two patterns must have \bold{identical} windows. If one pattern has marks, then the other must also have marks of the same type. It the marks are data frames then the number of columns of these data frames, and the names of the columns must be identical. (To combine two point patterns, see \code{superimpose}). If one of the arguments is \code{NULL}, it will be ignored and the other argument will be returned. } \seealso{ \code{\link{psp}}, \code{\link{as.psp}}, \code{\link{superimpose}}, } \examples{ X <- psp(runif(20), runif(20), runif(20), runif(20), window=owin()) Y <- psp(runif(5), runif(5), runif(5), runif(5), window=owin()) append.psp(X,Y) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/pp3.Rd0000644000176200001440000000242214611065350014610 0ustar liggesusers\name{pp3} \Rdversion{1.1} \alias{pp3} \title{ Three Dimensional Point Pattern } \description{ Create a three-dimensional point pattern } \usage{ pp3(x, y, z, ..., marks=NULL) } \arguments{ \item{x,y,z}{ Numeric vectors of equal length, containing Cartesian coordinates of points in three-dimensional space. } \item{\dots}{ Arguments passed to \code{\link{as.box3}} to determine the three-dimensional box in which the points have been observed. } \item{marks}{ Optional. Vector, data frame, or hyperframe of mark values associated with the points. } } \details{ An object of class \code{"pp3"} represents a pattern of points in three-dimensional space. The points are assumed to have been observed by exhaustively inspecting a three-dimensional rectangular box. The boundaries of the box are included as part of the dataset. } \value{ Object of class \code{"pp3"} representing a three dimensional point pattern. Also belongs to class \code{"ppx"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{box3}}, \code{\link{print.pp3}}, \code{\link{ppx}} } \examples{ X <- pp3(runif(10), runif(10), runif(10), box3(c(0,1)), marks=rnorm(10)) X } \keyword{spatial} \keyword{datagen} \concept{Three-dimensional} spatstat.geom/man/box3.Rd0000644000176200001440000000304414611065345014766 0ustar liggesusers\name{box3} \Rdversion{1.1} \alias{box3} \title{ Three-Dimensional Box } \description{ Creates an object representing a three-dimensional box. } \usage{ box3(xrange = c(0, 1), yrange = xrange, zrange = yrange, unitname = NULL) } \arguments{ \item{xrange, yrange, zrange}{ Dimensions of the box in the \eqn{x,y,z} directions. Each of these arguments should be a numeric vector of length 2. } \item{unitname}{ Optional. Name of the unit of length. See Details. } } \details{ This function creates an object representing a three-dimensional rectangular parallelepiped (box) with sides parallel to the coordinate axes. The object can be used to specify the domain of a three-dimensional point pattern (see \code{\link{pp3}}) and in various geometrical calculations (see \code{\link{volume.box3}}, \code{\link{diameter.box3}}, \code{\link{eroded.volumes}}). The optional argument \code{unitname} specifies the name of the unit of length. See \code{\link{unitname}} for valid formats. The function \code{\link{as.box3}} can be used to convert other kinds of data to this format. } \value{ An object of class \code{"box3"}. There is a print method for this class. } \author{\adrian and \rolf } \seealso{ \code{\link{as.box3}}, \code{\link{pp3}}, \code{\link{volume.box3}}, \code{\link{diameter.box3}}, \code{\link{eroded.volumes}}. } \examples{ box3() box3(c(0,10),c(0,10),c(0,5), unitname=c("metre","metres")) box3(c(-1,1)) } \keyword{spatial} \keyword{datagen} \concept{Three-dimensional} spatstat.geom/man/is.linnet.Rd0000644000176200001440000000105114611065351016007 0ustar liggesusers\name{is.linnet} \alias{is.linnet} \title{Test Whether An Object Is A Linear Network} \description{ Checks whether its argument is a linear network (object of class \code{"linnet"}). } \usage{ is.linnet(x) } \arguments{ \item{x}{Any object.} } \details{ This function tests whether the object \code{x} is a linear network (object of class \code{"linnet"}). } \value{ \code{TRUE} if \code{x} is of class \code{"linnet"}, otherwise \code{FALSE}. } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} \concept{Linear network} spatstat.geom/man/selfcut.psp.Rd0000644000176200001440000000303014611065350016350 0ustar liggesusers\name{selfcut.psp} \alias{selfcut.psp} \title{Cut Line Segments Where They Intersect} \description{ Finds any crossing points between the line segments in a line segment pattern, and cuts the segments into pieces at these crossing-points. } \usage{ selfcut.psp(A, \dots, eps) } \arguments{ \item{A}{ Line segment pattern (object of class \code{"psp"}). } \item{eps}{ Optional. Smallest permissible length of the resulting line segments. There is a sensible default. } \item{\dots}{Ignored.} } \details{ This function finds any crossing points between different line segments in the line segment pattern \code{A}, and cuts the line segments into pieces at these intersection points. A crossing point occurs whenever one of the line segments in \code{A} intersects another line segment in \code{A}, at a nonzero angle of intersection. } \value{ Another line segment pattern (object of class \code{"psp"}) in the same window as \code{A} with the same kind of marks as \code{A}. The result also has an attribute \code{"camefrom"} indicating the provenance of each segment in the result. For example \code{camefrom[3]=2} means that the third segment in the result is a piece of the second segment of \code{A}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{selfcrossing.psp}} } \examples{ X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) Y <- selfcut.psp(X) n <- nsegments(Y) plot(Y \%mark\% factor(sample(seq_len(n), n, replace=TRUE))) } \keyword{spatial} \keyword{manip} spatstat.geom/man/intensity.quadratcount.Rd0000644000176200001440000000426114643111575020656 0ustar liggesusers\name{intensity.quadratcount} \alias{intensity.quadratcount} \title{ Intensity Estimates Using Quadrat Counts } \description{ Uses quadrat count data to estimate the intensity of a point pattern in each tile of a tessellation, assuming the intensity is constant in each tile. } \usage{ \method{intensity}{quadratcount}(X, ..., image=FALSE) } \arguments{ \item{X}{ An object of class \code{"quadratcount"}. } \item{image}{ Logical value specifying whether to return a table of estimated intensities (the default) or a pixel image of the estimated intensity (\code{image=TRUE}). } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the resolution of the pixel image, if \code{image=TRUE}. } } \details{ This is a method for the generic function \code{\link{intensity}}. It computes an estimate of the intensity of a point pattern from its quadrat counts. The argument \code{X} should be an object of class \code{"quadratcount"}. It would have been obtained by applying the function \code{\link{quadratcount}} to a point pattern (object of class \code{"ppp"}). It contains the counts of the numbers of points of the point pattern falling in each tile of a tessellation. Using this information, \code{intensity.quadratcount} divides the quadrat counts by the tile areas, yielding the average density of points per unit area in each tile of the tessellation. If \code{image=FALSE} (the default), these intensity values are returned in a contingency table. Cells of the contingency table correspond to tiles of the tessellation. If \code{image=TRUE}, the estimated intensity function is returned as a pixel image. For each pixel, the pixel value is the estimated intensity in the tile which contains that pixel. } \value{ If \code{image=FALSE} (the default), a contingency table. If \code{image=TRUE}, a pixel image (object of class \code{"im"}). } \seealso{ \code{\link{intensity}}, \code{\link{quadratcount}} } \examples{ qa <- quadratcount(swedishpines, 4,3) qa intensity(qa) plot(intensity(qa, image=TRUE)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{nonparametric} spatstat.geom/man/simplepanel.Rd0000644000176200001440000002016514611065350016423 0ustar liggesusers\name{simplepanel} \alias{simplepanel} \alias{grow.simplepanel} \title{Simple Point-and-Click Interface Panels} \description{ These functions enable the user to create a simple, robust, point-and-click interface to any \R code. } \usage{ simplepanel(title, B, boxes, clicks, redraws=NULL, exit = NULL, env) grow.simplepanel(P, side = c("right", "left", "top", "bottom"), len = NULL, new.clicks, new.redraws=NULL, \dots, aspect) } \arguments{ \item{title}{ Character string giving the title of the interface panel. } \item{B}{ Bounding box of the panel coordinates. A rectangular window (object of class \code{"owin"}) } \item{boxes}{ A list of rectangular windows (objects of class \code{"owin"}) specifying the placement of the buttons and other interactive components of the panel. } \item{clicks}{ A list of \R functions, of the same length as \code{boxes}, specifying the operations to be performed when each button is clicked. Entries can also be \code{NULL} indicating that no action should occur. See Details. } \item{redraws}{ Optional list of \R functions, of the same length as \code{boxes}, specifying how to redraw each button. Entries can also be \code{NULL} indicating a simple default. See Details. } \item{exit}{ An \R function specifying actions to be taken when the interactive panel terminates. } \item{env}{ An \code{environment} that will be passed as an argument to all the functions in \code{clicks}, \code{redraws} and \code{exit}. } \item{P}{ An existing interaction panel (object of class \code{"simplepanel"}). } \item{side}{ Character string identifying which side of the panel \code{P} should be grown to accommodate the new buttons. } \item{len}{ Optional. Thickness of the new panel area that should be grown to accommodate the new buttons. A single number in the same units as the coordinate system of \code{P}. } \item{new.clicks}{ List of \R functions defining the operations to be performed when each of the new buttons is clicked. } \item{new.redraws}{ Optional. List of \R functions, of the same length as \code{new.clicks}, defining how to redraw each of the new buttons. } \item{\dots}{ Arguments passed to \code{\link{layout.boxes}} to determine the layout of the new buttons. } \item{aspect}{ Optional. Aspect ratio (height/width) of the new buttons. } } \details{ These functions enable the user to create a simple, robust, point-and-click interface to any \R code. The functions \code{simplepanel} and \code{grow.simplepanel} create an object of class \code{"simplepanel"}. Such an object defines the graphics to be displayed and the actions to be performed when the user interacts with the panel. The panel is activated by calling \code{\link{run.simplepanel}}. The function \code{simplepanel} creates a panel object from basic data. The function \code{grow.simplepanel} modifies an existing panel object \code{P} by growing an additional row or column of buttons. For \code{simplepanel}, \itemize{ \item The spatial layout of the panel is determined by the rectangles \code{B} and \code{boxes}. \item The argument \code{clicks} must be a list of functions specifying the action to be taken when each button is clicked (or \code{NULL} to indicate that no action should be taken). The list entries should have names (but there are sensible defaults). Each function should be of the form \code{function(env, xy)} where \code{env} is an \code{environment} that may contain shared data, and \code{xy} gives the coordinates of the mouse click, in the format \code{list(x, y)}. The function returns \code{TRUE} if the panel should continue running, and \code{FALSE} if the panel should terminate. \item The argument \code{redraws}, if given, must be a list of functions specifying the action to be taken when each button is to be redrawn. Each function should be of the form \code{function(button, name, env)} where \code{button} is a rectangle specifying the location of the button in the current coordinate system; \code{name} is a character string giving the name of the button; and \code{env} is the \code{environment} that may contain shared data. The function returns \code{TRUE} if the panel should continue running, and \code{FALSE} if the panel should terminate. If \code{redraws} is not given (or if one of the entries in \code{redraws} is \code{NULL}), the default action is to draw a pink rectangle showing the button position, draw the name of the button in the middle of this rectangle, and return \code{TRUE}. \item The argument \code{exit}, if given, must be a function specifying the action to be taken when the panel terminates. (Termination occurs when one of the \code{clicks} functions returns \code{FALSE}). The \code{exit} function should be of the form \code{function(env)} where \code{env} is the \code{environment} that may contain shared data. Its return value will be used as the return value of \code{\link{run.simplepanel}}. \item The argument \code{env} should be an \R environment. The panel buttons will have access to this environment, and will be able to read and write data in it. This mechanism is used to exchange data between the panel and other \R code. } For \code{grow.simplepanel}, \itemize{ \item the spatial layout of the new boxes is determined by the arguments \code{side}, \code{len}, \code{aspect} and by the additional \code{\dots} arguments passed to \code{\link{layout.boxes}}. \item the argument \code{new.clicks} should have the same format as \code{clicks}. It implicitly specifies the number of new buttons to be added, and the actions to be performed when they are clicked. \item the optional argument \code{new.redraws}, if given, should have the same format as \code{redraws}. It specifies the actions to be performed when the new buttons are clicked. } } \value{ An object of class \code{"simplepanel"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{run.simplepanel}}, \code{\link{layout.boxes}} } \examples{ # make boxes (alternatively use layout.boxes()) Bminus <- square(1) Bvalue <- shift(Bminus, c(1.2, 0)) Bplus <- shift(Bvalue, c(1.2, 0)) Bdone <- shift(Bplus, c(1.2, 0)) myboxes <- list(Bminus, Bvalue, Bplus, Bdone) myB <- do.call(boundingbox,myboxes) # make environment containing an integer count myenv <- new.env() assign("answer", 0, envir=myenv) # what to do when finished: return the count. myexit <- function(e) { return(get("answer", envir=e)) } # button clicks # decrement the count Cminus <- function(e, xy) { ans <- get("answer", envir=e) assign("answer", ans - 1, envir=e) return(TRUE) } # display the count (clicking does nothing) Cvalue <- function(...) { TRUE } # increment the count Cplus <- function(e, xy) { ans <- get("answer", envir=e) assign("answer", ans + 1, envir=e) return(TRUE) } # 'Clear' button Cclear <- function(e, xy) { assign("answer", 0, envir=e) return(TRUE) } # quit button Cdone <- function(e, xy) { return(FALSE) } myclicks <- list("-"=Cminus, value=Cvalue, "+"=Cplus, done=Cdone) # redraw the button that displays the current value of the count Rvalue <- function(button, nam, e) { plot(button, add=TRUE) ans <- get("answer", envir=e) text(centroid.owin(button), labels=ans) return(TRUE) } # make the panel P <- simplepanel("Counter", B=myB, boxes=myboxes, clicks=myclicks, redraws = list(NULL, Rvalue, NULL, NULL), exit=myexit, env=myenv) # print it P # show what it looks like redraw.simplepanel(P) # ( type run.simplepanel(P) to run the panel interactively ) # add another button to right Pplus <- grow.simplepanel(P, "right", new.clicks=list(clear=Cclear)) } \keyword{iplot} \keyword{utilities} spatstat.geom/man/funxy.Rd0000644000176200001440000000413314611065346015265 0ustar liggesusers\name{funxy} \Rdversion{1.1} \alias{funxy} \title{ Spatial Function Class } \description{ A simple class of functions of spatial location } \usage{ funxy(f, W) } \arguments{ \item{f}{ A \code{function} in the \R language with arguments \code{x,y} (at least) } \item{W}{ Window (object of class \code{"owin"}) inside which the function is well-defined. } } \details{ This command creates an object of class \code{"funxy"}. This is a simple mechanism for handling a function of spatial location \eqn{f(x,y)} to make it easier to display and manipulate. \code{f} should be a \code{function} in the \R language. The first two arguments of \code{f} must be named \code{x} and \code{y} respectively. \code{W} should be a window (object of class \code{"owin"}) inside which the function \code{f} is well-defined. The function \code{f} should be vectorised: that is, if \code{x} and \code{y} are numeric vectors of the same length \code{n}, then \code{v <- f(x,y)} should be a vector of length \code{n}. The resulting function \code{g <- funxy(f, W)} has the same formal arguments as \code{f} and can be called in the same way, \code{v <- g(x,y)} where \code{x} and \code{y} are numeric vectors. However it can also be called as \code{v <- g(X)}, where \code{X} is a point pattern (object of class \code{"ppp"} or \code{"lpp"}) or a quadrature scheme (class \code{"quad"}); the function will be evaluated at the points of \code{X}. The result also has a \code{\link{unitname}}, inherited from \code{W}. } \value{ A \code{function} with the same arguments as \code{f}, which also belongs to the class \code{"funxy"}. This class has methods for \code{print}, \code{plot}, \code{contour} and \code{persp}. } \seealso{ \code{\link{plot.funxy}}, \code{\link{summary.funxy}} } \examples{ f <- function(x,y) { x^2 + y^2 - 1} g <- funxy(f, square(2)) g ## evaluate function at any x, y coordinates g(0.2, 0.3) ## evaluate function at the points of a point pattern g(cells[1:4]) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/where.max.Rd0000644000176200001440000000345214611065351016011 0ustar liggesusers\name{where.max} \alias{where.max} \alias{where.min} \title{ Find Location of Maximum in a Pixel Image } \description{ Finds the spatial location(s) where a given pixel image attains its maximum or minimum value. } \usage{ where.max(x, first = TRUE) where.min(x, first = TRUE) } \arguments{ \item{x}{ A pixel image (object of class \code{"im"}) or data that can be converted to a pixel image by \code{\link{as.im}}. } \item{first}{ Logical value. If \code{TRUE} (the default), then only one location will be returned. If \code{FALSE}, then all locations where the maximum is achieved will be returned. } } \details{ This function finds the spatial location or locations where the pixel image \code{x} attains its maximum or minimum value. The result is a point pattern giving the locations. If \code{first=TRUE} (the default), then only one location will be returned, namely the location with the smallest \eqn{y} coordinate value which attains the maximum or minimum. This behaviour is analogous to the functions \code{\link[base]{which.min}} and \code{\link[base:which.min]{which.max}}. If \code{first=FALSE}, then the function returns the locations of all pixels where the maximum (or minimum) value is attained. This could be a large number of points. } \value{ A point pattern (object of class \code{"ppp"}). } \author{ \adrian } \seealso{ \code{\link{Summary.im}} for computing the minimum and maximum of pixel values; \code{\link{eval.im}} and \code{\link{Math.im}} for mathematical expressions involving images; \code{\link{solutionset}} for finding the set of pixels where a statement is true. } \examples{ D <- distmap(letterR, invert=TRUE) plot(D) plot(where.max(D), add=TRUE, pch=16, cols="green") } \keyword{spatial} \keyword{math} spatstat.geom/man/persp.ppp.Rd0000644000176200001440000001436614707626330016056 0ustar liggesusers\name{persp.ppp} \alias{persp.ppp} \title{ Perspective Plot of Marked Point Pattern } \description{ For a spatial point pattern with numeric marks, generate a perspective plot in which each data point is shown as a vertical spike, with height proportional to the mark value. } \usage{ \method{persp}{ppp}(x, \dots, main, type=c("l", "b"), grid = TRUE, ngrid = 10, col.grid = "grey", col.base = "white", win.args=list(), spike.args = list(), neg.args = list(), point.args=list(), which.marks = 1, zlab = NULL, zlim = NULL, zadjust = 1, legend=TRUE, legendpos="bottomleft", leg.args=list(lwd=4), leg.col=c("black", "orange")) } \arguments{ \item{x}{ A spatial point pattern (object of class \code{"ppp"}) with numeric marks, or a data frame of marks. } \item{\dots}{ Additional graphical arguments passed to \code{\link{persp.default}} to determine the perspective view (for example the rotation angle \code{theta} and the elevation angle \code{phi}) or passed to \code{\link[graphics]{segments}} to control the drawing of lines (for example \code{lwd} for line width) or passed to \code{\link[graphics]{points.default}} to control the drawing of points (for example \code{pch} for symbol type). } \item{main}{ Optional main title for the plot. } \item{type}{ Single character specifying how each observation will be plotted: \code{type="l"} for lines, \code{type="b"} for both lines and points. } \item{grid}{ Logical value specifying whether to draw a grid of reference lines on the horizontal plane. } \item{ngrid}{ Number of grid lines to draw in each direction, if \code{grid=TRUE}. An integer, or a pair of integers specifying the number of grid lines along the horizontal and vertical axes respectively. } \item{col.grid}{ Colour of grid lines, if \code{grid=TRUE}. } \item{col.base}{ Colour with which to fill the horizontal plane. } \item{win.args}{ List of arguments passed to \code{\link{plot.owin}} to control the drawing of the window of \code{x}. Applicable only when the window is not a rectangle. } \item{spike.args}{ List of arguments passed to \code{\link[graphics]{segments}} to control the drawing of the spikes. } \item{neg.args}{ List of arguments passed to \code{\link[graphics]{segments}} applicable only to those spikes which have negative height (corresponding to a mark value which is negative). } \item{point.args}{ List of arguments passed to \code{\link[graphics]{points.default}} to control the drawing of the points, when \code{type="b"}. } \item{which.marks}{ Integer, or character name, identifying the column of marks which should be used, when \code{marks(x)} is a data frame. } \item{zlab}{ Optional. Label for the vertical axis. Character string or expression. } \item{zlim}{ Optional. Range of values on the vertical axis. A numeric vector of length 2. } \item{zadjust}{ Scale adjustment factor controlling the height of spikes. } \item{legend}{ Logical value specifying whether to draw a reference scale bar for the vertical axis. } \item{legendpos}{ Position of the reference scale bar. Either a character string matching one of the options \code{"bottomleft"}, \code{"bottomright"}, \code{"topleft"}, \code{"topright"}, \code{"bottom"}, \code{"left"}, \code{"top"} or \code{"right"}, or a numeric vector of length 2 specifing the coordinate position of the base of the reference scale bar. } \item{leg.args}{ Additional arguments passed to \code{\link[graphics]{segments}} to control the drawing of the reference scale bar. } \item{leg.col}{ A vector (usually of length 2) of colour values for successive intervals in the reference scale. The default is a reference scale consisting of black and orange stripes. } } \details{ The function \code{\link[graphics]{persp}} is generic. This is the method for spatial point patterns (objects of class \code{"ppp"}). The argument \code{x} must be a point pattern with numeric marks, or with a data frame of marks. A perspective view will be plotted. The eye position is determined by the arguments \code{theta} and \code{phi} passed to \code{\link[graphics]{persp.default}}. First the horizontal plane is drawn in perspective view, using a faint grid of lines to help suggest the perspective. Next the observation window of \code{x} is placed on the horizontal plane and its edges are drawn in perspective view. Finally for each data point in \code{x}, a vertical spike is erected at the spatial location of the data point, with height equal to the mark value of the point. If any mark values are negative, the corresponding spikes will penetrate below the horizontal plane. They can be drawn in a different colour by specifying \code{neg.args} as shown in the examples. Like all spatial plots in the \pkg{spatstat} family, \code{persp.ppp} does not independently rescale the \eqn{x} and \eqn{y} coordinates. A long narrow window will be represented as a long narrow window in the perspective view. To override this and allow the coordinates to be independently rescaled, use the argument \code{scale=TRUE} which will be passed to \code{\link[graphics]{persp.default}}. } \value{ (Invisibly) the perspective transformation matrix. } \author{ Adrian Baddeley. } \examples{ persp(longleaf, theta=-30, phi=35, spike.args=list(lwd=3), zadjust=1.5) # negative mark values X <- longleaf marks(X) <- marks(X) - 20 persp(X, theta=80, phi=35, neg.args=list(col="red"), spike.args=list(lwd=3), zadjust=1.2) # irregular window Australia <- Window(austates) Y <- runifrect(70, Frame(Australia))[Australia] marks(Y) <- runif(npoints(Y)) persp(Y, theta=30, phi=20, col.base="lightblue", win.args=list(col="pink", border=NA), spike.args=list(lwd=2), zadjust=1.5) persp(Y, type="b", theta=30, phi=20, col.base="lightblue", win.args=list(col="pink", border=NA), spike.args=list(lty=3), point.args=list(col="blue"), zadjust=1.5) } \keyword{hplot} \keyword{spatial} spatstat.geom/man/clickbox.Rd0000644000176200001440000000246114611065345015713 0ustar liggesusers\name{clickbox} \alias{clickbox} \title{Interactively Define a Rectangle} \description{ Allows the user to specify a rectangle by point-and-click in the display. } \usage{ clickbox(add=TRUE, \dots) } \arguments{ \item{add}{ Logical value indicating whether to create a new plot (\code{add=FALSE}) or draw over the existing plot (\code{add=TRUE}). } \item{\dots}{ Graphics arguments passed to \code{\link[graphics]{polygon}} to plot the box. } } \value{ A window (object of class \code{"owin"}) representing the selected rectangle. } \details{ This function allows the user to create a rectangular window by interactively clicking on the screen display. The user is prompted to point the mouse at any desired locations for two corners of the rectangle, and click the left mouse button to add each point. The return value is a window (object of class \code{"owin"}) representing the rectangle. This function uses the \R command \code{\link[graphics]{locator}} to input the mouse clicks. It only works on screen devices such as \sQuote{X11}, \sQuote{windows} and \sQuote{quartz}. } \seealso{ \code{\link{clickpoly}}, \code{\link{clickppp}}, \code{\link{clickdist}}, \code{\link[graphics]{locator}} } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{iplot} spatstat.geom/man/print.psp.Rd0000644000176200001440000000133614611065350016046 0ustar liggesusers\name{print.psp} \alias{print.psp} \title{Print Brief Details of a Line Segment Pattern Dataset} \description{ Prints a very brief description of a line segment pattern dataset. } \usage{ \method{print}{psp}(x, \dots) } \arguments{ \item{x}{Line segment pattern (object of class \code{"psp"}).} \item{\dots}{Ignored.} } \details{ A very brief description of the line segment pattern \code{x} is printed. This is a method for the generic function \code{\link{print}}. } \seealso{ \code{\link{print}}, \code{\link{print.owin}}, \code{\link{summary.psp}} } \examples{ a <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) a } \author{\adrian and \rolf } \keyword{spatial} \keyword{print} spatstat.geom/man/infline.Rd0000644000176200001440000000603114611065346015537 0ustar liggesusers\name{infline} \alias{infline} \alias{plot.infline} \alias{print.infline} \title{Infinite Straight Lines} \description{ Define the coordinates of one or more straight lines in the plane } \usage{ infline(a = NULL, b = NULL, h = NULL, v = NULL, p = NULL, theta = NULL) \method{print}{infline}(x, \dots) \method{plot}{infline}(x, \dots) } \arguments{ \item{a,b}{Numeric vectors of equal length giving the intercepts \eqn{a} and slopes \eqn{b} of the lines. Incompatible with \code{h,v,p,theta} } \item{h}{Numeric vector giving the positions of horizontal lines when they cross the \eqn{y} axis. Incompatible with \code{a,b,v,p,theta} } \item{v}{Numeric vector giving the positions of vertical lines when they cross the \eqn{x} axis. Incompatible with \code{a,b,h,p,theta} } \item{p,theta}{Numeric vectors of equal length giving the polar coordinates of the line. Incompatible with \code{a,b,h,v} } \item{x}{An object of class \code{"infline"}} \item{\dots}{ Extra arguments passed to \code{\link[base]{print}} for printing or \code{\link[graphics]{abline}} for plotting } } \details{ The class \code{infline} is a convenient way to handle infinite straight lines in the plane. The position of a line can be specified in several ways: \itemize{ \item its intercept \eqn{a} and slope \eqn{b} in the equation \eqn{y = a + b x}{y = a + b * x} can be used unless the line is vertical. \item for vertical lines we can use the position \eqn{v} where the line crosses the \eqn{y} axis \item for horizontal lines we can use the position \eqn{h} where the line crosses the \eqn{x} axis \item the polar coordinates \eqn{p} and \eqn{\theta}{theta} can be used for any line. The line equation is \deqn{ x \cos\theta + y \sin\theta = p }{ x * cos(theta) + y * sin(theta) = p } } The command \code{infline} will accept line coordinates in any of these formats. The arguments \code{a,b,h,v} have the same interpretation as they do in the line-plotting function \code{\link[graphics]{abline}}. The command \code{infline} converts between different coordinate systems (e.g. from \code{a,b} to \code{p,theta}) and returns an object of class \code{"infline"} that contains a representation of the lines in each appropriate coordinate system. This object can be printed and plotted. } \value{ The value of \code{infline} is an object of class \code{"infline"} which is basically a data frame with columns \code{a,b,h,v,p,theta}. Each row of the data frame represents one line. Entries may be \code{NA} if a coordinate is not applicable to a particular line. } \seealso{ \code{\link{rotate.infline}}, \code{\link{clip.infline}}, \code{\link{chop.tess}}, \code{\link{whichhalfplane}} } \examples{ infline(a=10:13,b=1) infline(p=1:3, theta=pi/4) plot(c(-1,1),c(-1,1),type="n",xlab="",ylab="", asp=1) plot(infline(p=0.4, theta=seq(0,pi,length=20))) } \author{ \adrian and \rolf. } \keyword{spatial} \keyword{datagen} spatstat.geom/man/complement.owin.Rd0000644000176200001440000000375114611065345017236 0ustar liggesusers\name{complement.owin} \alias{complement.owin} \title{Take Complement of a Window} \description{ Take the set complement of a window, within its enclosing rectangle or in a larger rectangle. } \usage{ complement.owin(w, frame=as.rectangle(w)) } \arguments{ \item{w}{ an object of class \code{"owin"} describing a window of observation for a point pattern. } \item{frame}{ Optional. The enclosing rectangle, with respect to which the set complement is taken. } } \value{ Another object of class \code{"owin"} representing the complement of the window, i.e. the inside of the window becomes the outside. } \details{ This yields a window object (of class \code{"owin"}, see \code{\link{owin.object}}) representing the set complement of \code{w} with respect to the rectangle \code{frame}. By default, \code{frame} is the enclosing box of \code{w} (originally specified by the arguments \code{xrange} and \code{yrange} given to \code{\link{owin}} when \code{w} was created). If \code{frame} is specified, it must be a rectangle (an object of class \code{"owin"} whose type is \code{"rectangle"}) and it must be larger than the enclosing box of \code{w}. This rectangle becomes the enclosing box for the resulting window. If \code{w} is a rectangle, then \code{frame} must be specified. Otherwise an error will occur (since the complement of \code{w} in itself is empty). For rectangular and polygonal windows, the complement is computed by reversing the sign of each boundary polygon, while for binary masks it is computed by negating the pixel values. } \seealso{ \code{\link{owin}}, \code{\link{owin.object}} } \examples{ # rectangular a <- owin(c(0,1),c(0,1)) b <- owin(c(-1,2),c(-1,2)) bmina <- complement.owin(a, frame=b) # polygonal w <- Window(demopat) outside <- complement.owin(w) # mask w <- as.mask(Window(demopat)) outside <- complement.owin(w) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/unmark.Rd0000644000176200001440000000234514611065351015410 0ustar liggesusers\name{unmark} \alias{unmark} \alias{unmark.ppp} \alias{unmark.splitppp} \alias{unmark.psp} \alias{unmark.ppx} \title{Remove Marks} \description{ Remove the mark information from a spatial dataset. } \usage{ unmark(X) \method{unmark}{ppp}(X) \method{unmark}{splitppp}(X) \method{unmark}{psp}(X) \method{unmark}{ppx}(X) } \arguments{ \item{X}{A point pattern (object of class \code{"ppp"}), a split point pattern (object of class \code{"splitppp"}), a line segment pattern (object of class \code{"psp"}) or a multidimensional space-time point pattern (object of class \code{"ppx"}). } } \value{ An object of the same class as \code{X} with any mark information deleted. } \details{ A `mark' is a value attached to each point in a spatial point pattern, or attached to each line segment in a line segment pattern, etc. The function \code{unmark} is a simple way to remove the marks from such a dataset. } \seealso{ \code{\link{ppp.object}}, \code{\link{psp.object}} } \examples{ hicks <- lansing[lansing$marks == "hickory", ] # plot(hicks) # still a marked point pattern, but only 1 value of marks # plot(unmark(hicks)) # unmarked } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/distmap.ppp.Rd0000644000176200001440000000646714742317357016376 0ustar liggesusers\name{distmap.ppp} \alias{distmap.ppp} \title{ Distance Map of Point Pattern } \description{ Computes the distance from each pixel to the nearest point in the given point pattern. } \usage{ \method{distmap}{ppp}(X, \dots, clip=FALSE, metric=NULL) } \arguments{ \item{X}{A point pattern (object of class \code{"ppp"}). } \item{\dots}{Arguments passed to \code{\link[spatstat.geom]{as.mask}} to control pixel resolution. } \item{clip}{ Logical value specifying whether the resulting pixel image should be clipped to the window of \code{X}. } \item{metric}{ Optional. A distance metric (object of class \code{"metric"}, see \code{\link{metric.object}}) which will be used to compute the distances. } } \value{ A pixel image (object of class \code{"im"}) whose greyscale values are the values of the distance map. The return value has attributes \code{"index"} and \code{"bdry"} which are also pixel images. } \details{ The ``distance map'' of a point pattern \eqn{X} is the function \eqn{f} whose value \code{f(u)} is defined for any two-dimensional location \eqn{u} as the shortest distance from \eqn{u} to \eqn{X}. This function computes the distance map of the point pattern \code{X} and returns the distance map as a pixel image. The greyscale value at a pixel \eqn{u} equals the distance from \eqn{u} to the nearest point of the pattern \code{X}. If \code{clip=FALSE} (the default), the resulting pixel values are defined at every pixel in the rectangle \code{Frame(X)}. If \code{clip=TRUE}, the pixel values are defined only inside \code{Window(X)}, and are \code{NA} outside this window. Computation is faster when \code{clip=FALSE}. Additionally, the return value has two attributes, \code{"index"} and \code{"bdry"}, which are also pixel images. The grey values in \code{"bdry"} give the distance from each pixel to the boundary of the window containing \code{X}. The grey values in \code{"index"} are integers identifying which point of \code{X} is closest. This is a method for the generic function \code{\link{distmap}}. Note that this function gives the distance from the \emph{centre of each pixel} to the nearest data point. To compute the exact distance from a given spatial location to the nearest data point in \code{X}, use \code{\link{distfun}} or \code{\link{nncross}}. } \section{Distance values}{ The pixel values in the image \code{distmap(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values in \code{distmap(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ Generic function \code{\link{distmap}} and other methods \code{\link{distmap.psp}}, \code{\link{distmap.owin}}. Generic function \code{\link{distfun}}. Nearest neighbour distance \code{\link{nncross}}. \code{\link{unitname}} and \code{\link{rescale}} to control the unit of length. } \examples{ U <- distmap(cells) if(interactive()) { plot(U) plot(attr(U, "bdry")) plot(attr(U, "index")) } } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/update.symbolmap.Rd0000644000176200001440000000223414611065351017374 0ustar liggesusers\name{update.symbolmap} \alias{update.symbolmap} \title{ Update a Graphics Symbol Map. } \description{ This command updates the \code{object} using the arguments given. } \usage{ \method{update}{symbolmap}(object, \dots) } \arguments{ \item{object}{ Graphics symbol map (object of class \code{"symbolmap"}). } \item{\dots}{ Additional or replacement arguments to \code{\link{symbolmap}}. } } \details{ This is a method for the generic function \code{\link[stats]{update}} for the class \code{"symbolmap"} of graphics symbol maps. It updates the \code{object} using the parameters given in the extra arguments \code{\dots}. The extra arguments must be given in the form \code{name=value} and must be recognisable to \code{\link{symbolmap}}. They override any parameters of the same name in \code{object}. } \value{ Another object of class \code{"symbolmap"}. } \author{\spatstatAuthors.} \seealso{ \code{\link{symbolmap}} to create a graphics symbol map. } \examples{ g <- symbolmap(size=function(x) x/50) g update(g, range=c(0,1)) update(g, size=42) update(g, shape="squares", range=c(0,1)) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/compatible.Rd0000644000176200001440000000200314611065345016224 0ustar liggesusers\name{compatible} \alias{compatible} \title{Test Whether Objects Are Compatible} \description{ Tests whether two or more objects of the same class are compatible. } \usage{ compatible(A, B, \dots) } \arguments{ \item{A,B,\dots}{Two or more objects of the same class} } \details{ This generic function is used to check whether the objects \code{A} and \code{B} (and any additional objects \code{\dots}) are compatible. What is meant by \sQuote{compatible} depends on the class of object. There are methods for the classes \code{"fv"}, \code{"fasp"}, \code{"im"} and \code{"unitname"}. See the documentation for these methods for further information. } \value{ Logical value: \code{TRUE} if the objects are compatible, and \code{FALSE} if they are not. } \seealso{ \code{\link[spatstat.explore]{compatible.fv}}, \code{\link[spatstat.explore]{compatible.fasp}}, \code{\link{compatible.im}}, \code{\link{compatible.unitname}} } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/integral.im.Rd0000644000176200001440000000515614611065613016330 0ustar liggesusers\name{integral.im} \alias{integral.im} \title{ Integral of a Pixel Image } \description{ Computes the integral of a pixel image. } \usage{ \method{integral}{im}(f, domain=NULL, weight=NULL, \dots) } \arguments{ \item{f}{ A pixel image (object of class \code{"im"}) with pixel values that can be treated as numeric or complex values. } \item{domain}{ Optional. Window specifying the domain of integration. Alternatively a tessellation. } \item{\dots}{ Ignored. } \item{weight}{ Optional. A pixel image (object of class \code{"im"}) or a \code{function(x,y)} giving a numerical weight to be applied to the integration. } } \details{ The function \code{\link[spatstat.univar]{integral}} is generic, with methods for spatial objects (\code{"im"}, \code{"msr"}, \code{"linim"}, \code{"linfun"}) and one-dimensional functions (\code{"density"}, \code{"fv"}). The method \code{integral.im} treats the pixel image \code{f} as a function of the spatial coordinates, and computes its integral. The integral is calculated by summing the pixel values and multiplying by the area of one pixel. The pixel values of \code{f} may be numeric, integer, logical or complex. They cannot be factor or character values. The logical values \code{TRUE} and \code{FALSE} are converted to \code{1} and \code{0} respectively, so that the integral of a logical image is the total area of the \code{TRUE} pixels, in the same units as \code{unitname(x)}. If \code{domain} is a window (class \code{"owin"}) then the integration will be restricted to this window. If \code{domain} is a tessellation (class \code{"tess"}) then the integral of \code{f} in each tile of \code{domain} will be computed. If \code{weight} is given, it should be a pixel image or a function of coordinates \eqn{x} and \eqn{y} returning numerical values. Then each pixel value of \code{f} will be multiplied by the corresponding value of \code{weight}. Effectively, the result is the integral of \code{weight * f}. } \value{ A single numeric or complex value (or a vector of such values if \code{domain} is a tessellation). } \seealso{ \code{\link[spatstat.univar]{integral}}, \code{\link{eval.im}}, \code{\link{[.im}} } \examples{ # approximate integral of f(x,y) dx dy f <- function(x,y){3*x^2 + 2*y} Z <- as.im(f, square(1)) integral(Z) # correct answer is 2 # integrate over the subset [0.1,0.9] x [0.2,0.8] W <- owin(c(0.1,0.9), c(0.2,0.8)) integral(Z, W) # weighted integral integral(Z, weight=function(x,y){x}) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/is.boxx.Rd0000644000176200001440000000142714611065346015511 0ustar liggesusers\name{is.boxx} \Rdversion{1.1} \alias{is.boxx} \title{ Recognise a Multi-Dimensional Box } \description{ Checks whether its argument is a multidimensional box (object of class \code{"boxx"}). } \usage{ is.boxx(x) } \arguments{ \item{x}{ Any object. } } \details{ This function tests whether the object \code{x} is a multidimensional box of class \code{"boxx"}. The result is determined to be \code{TRUE} if \code{x} inherits from \code{"boxx"}, i.e. if \code{x} has \code{"boxx"} amongst its classes. } \value{ A logical value. } \author{ \spatstatAuthors } \seealso{ \code{\link{methods.boxx}}, \code{\link{boxx}}. } \examples{ B <- boxx(c(0,10),c(0,10),c(0,5),c(0,1), unitname="km") is.boxx(B) is.boxx(42) } \keyword{spatial} \keyword{methods} spatstat.geom/man/rotate.im.Rd0000644000176200001440000000207314611065350016012 0ustar liggesusers\name{rotate.im} \alias{rotate.im} \title{Rotate a Pixel Image} \description{ Rotates a pixel image } \usage{ \method{rotate}{im}(X, angle=pi/2, \dots, centre=NULL) } \arguments{ \item{X}{A pixel image (object of class \code{"im"}).} \item{angle}{Angle of rotation, in radians.} \item{\dots}{Ignored.} \item{centre}{ Centre of rotation. Either a vector of length 2, or a character string (partially matched to \code{"centroid"}, \code{"midpoint"} or \code{"bottomleft"}). The default is the coordinate origin \code{c(0,0)}. } } \value{ Another object of class \code{"im"} representing the rotated pixel image. } \details{ The image is rotated by the angle specified. Angles are measured in radians, anticlockwise. The default is to rotate the image 90 degrees anticlockwise. } \seealso{ \code{\link{affine.im}}, \code{\link{shift.im}}, \code{\link{rotate}} } \examples{ Z <- distmap(letterR) X <- rotate(Z) # plot(X) Y <- rotate(X, centre="midpoint") } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/rotate.owin.Rd0000644000176200001440000000273414643111575016373 0ustar liggesusers\name{rotate.owin} \alias{rotate.owin} \title{Rotate a Window} \description{ Rotates a window } \usage{ \method{rotate}{owin}(X, angle=pi/2, \dots, rescue=TRUE, centre=NULL) } \arguments{ \item{X}{A window (object of class \code{"owin"}).} \item{angle}{Angle of rotation.} \item{rescue}{ Logical. If \code{TRUE}, the rotated window will be processed by \code{\link{rescue.rectangle}}. } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the resolution of the rotated window, if \code{X} is a binary pixel mask. Ignored if \code{X} is not a binary mask. } \item{centre}{ Centre of rotation. Either a vector of length 2, or a character string (partially matched to \code{"centroid"}, \code{"midpoint"} or \code{"bottomleft"}). The default is the coordinate origin \code{c(0,0)}. } } \value{ Another object of class \code{"owin"} representing the rotated window. } \details{ Rotates the window by the specified angle. Angles are measured in radians, anticlockwise. The default is to rotate the window 90 degrees anticlockwise. The centre of rotation is the origin, by default, unless \code{centre} is specified. } \seealso{ \code{\link{owin.object}} } \examples{ w <- owin(c(0,1),c(0,1)) v <- rotate(w, pi/3) e <- rotate(w, pi/2, centre="midpoint") # plot(v) w <- as.mask(letterR) v <- rotate(w, pi/5) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/subset.hyperframe.Rd0000644000176200001440000000454514611065350017564 0ustar liggesusers\name{subset.hyperframe} \alias{subset.hyperframe} \title{ Subset of Hyperframe Satisfying A Condition } \description{ Given a hyperframe, return the subset specified by imposing a condition on each row, and optionally by choosing only some of the columns. } \usage{ \method{subset}{hyperframe}(x, subset, select, \dots) } \arguments{ \item{x}{ A hyperframe pattern (object of class \code{"hyperframe"}. } \item{subset}{ Logical expression indicating which points are to be kept. The expression may involve the names of columns of \code{x} and will be evaluated by \code{\link{with.hyperframe}}. } \item{select}{ Expression indicating which columns of marks should be kept. } \item{\dots}{ Arguments passed to \code{\link{[.hyperframe}} such as \code{drop} and \code{strip}. } } \details{ This is a method for the generic function \code{\link{subset}}. It extracts the subset of rows of \code{x} that satisfy the logical expression \code{subset}, and retains only the columns of \code{x} that are specified by the expression \code{select}. The result is always a hyperframe. The argument \code{subset} determines the subset of rows that will be extracted. It should be a logical expression. It may involve the names of columns of \code{x}. The default is to keep all points. The argument \code{select} determines which columns of \code{x} will be retained. It should be an expression involving the names of columns (which will be interpreted as integers representing the positions of these columns). For example if there are columns named \code{A} to \code{Z}, then \code{select=D:F} is a valid expression and means that columns \code{D}, \code{E} and \code{F} will be retained. Similarly \code{select=-(A:C)} is valid and means that columns \code{A} to \code{C} will be deleted. The default is to retain all columns. Setting \code{subset=FALSE} will remove all the rows. Setting \code{select=FALSE} will remove all the columns. The result is always a hyperframe. } \value{ A hyperframe. } \author{\adrian , \rolf and \ege } \seealso{ \code{\link[base]{subset}}, \code{\link{[.hyperframe}} } \examples{ a <- subset(flu, virustype=="wt") aa <- subset(flu, minnndist(pattern) > 10) aaa <- subset(flu, virustype=="wt", select = -pattern) } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.solist.Rd0000644000176200001440000000176414611065345016041 0ustar liggesusers\name{as.solist} \alias{as.solist} \title{ Convert List of Two-Dimensional Spatial Objects } \description{ Given a list of two-dimensional spatial objects, convert it to the class \code{"solist"}. } \usage{ as.solist(x, \dots) } \arguments{ \item{x}{ A list of objects, each representing a two-dimensional spatial dataset. } \item{\dots}{ Additional arguments passed to \code{\link{solist}}. } } \details{ This command makes the list \code{x} into an object of class \code{"solist"} (spatial object list). See \code{\link{solist}} for details. The entries in the list \code{x} should be two-dimensional spatial datasets (not necessarily of the same class). } \value{ A list, usually of class \code{"solist"}. } \seealso{ \code{\link{solist}}, \code{\link{as.anylist}}, \code{\link{solapply}}. } \examples{ x <- list(cells, Window(cells), setcov(Window(cells))) y <- as.solist(x) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{list} \keyword{manip} spatstat.geom/man/split.ppp.Rd0000644000176200001440000001463214611065350016045 0ustar liggesusers\name{split.ppp} \alias{split.ppp} \alias{split<-.ppp} \title{Divide Point Pattern into Sub-patterns} \description{ Divides a point pattern into several sub-patterns, according to their marks, or according to any user-specified grouping. } \usage{ \method{split}{ppp}(x, f = marks(x), drop=FALSE, un=NULL, reduce=FALSE, \dots) \method{split}{ppp}(x, f = marks(x), drop=FALSE, un=NULL, \dots) <- value } \arguments{ \item{x}{ A two-dimensional point pattern. An object of class \code{"ppp"}. } \item{f}{ Data determining the grouping. Either a factor, a logical vector, a pixel image with factor values, a tessellation, a window, or the name of one of the columns of marks. } \item{drop}{ Logical. Determines whether empty groups will be deleted. } \item{un}{ Logical. Determines whether the resulting subpatterns will be unmarked (i.e. whether marks will be removed from the points in each subpattern). } \item{reduce}{ Logical. Determines whether to delete the column of marks used to split the pattern, when the marks are a data frame. } \item{\dots}{ Other arguments are ignored. } \item{value}{ List of point patterns. } } \value{ The value of \code{split.ppp} is a list of point patterns. The components of the list are named by the levels of \code{f}. The list also has the class \code{"splitppp"}. The assignment form \code{split<-.ppp} returns the updated point pattern \code{x}. } \details{ The function \code{split.ppp} divides up the points of the point pattern \code{x} into several sub-patterns according to the values of \code{f}. The result is a list of point patterns. The argument \code{f} may be \itemize{ \item a factor, of length equal to the number of points in \code{x}. The levels of \code{f} determine the destination of each point in \code{x}. The \code{i}th point of \code{x} will be placed in the sub-pattern \code{split.ppp(x)$l} where \code{l = f[i]}. \item a pixel image (object of class \code{"im"}) with factor values. The pixel value of \code{f} at each point of \code{x} will be used as the classifying variable. \item a tessellation (object of class \code{"tess"}). Each point of \code{x} will be classified according to the tile of the tessellation into which it falls. \item a window (object of class \code{"owin"}). Each point of \code{x} will be classified according to whether it falls inside or outside this window. \item the character string \code{"marks"}, if \code{marks(x)} is a factor. \item a character string, matching the name of one of the columns of marks, if \code{marks(x)} is a data frame. This column should be a factor. } If \code{f} is missing, then it will be determined by the marks of the point pattern. The pattern \code{x} can be either \itemize{ \item a multitype point pattern (a marked point pattern whose marks vector is a factor). Then \code{f} is taken to be the marks vector. The effect is that the points of each type are separated into different point patterns. \item a marked point pattern with a data frame of marks, containing at least one column that is a factor. The first such column will be used to determine the splitting factor \code{f}. } Some of the sub-patterns created by the split may be empty. If \code{drop=TRUE}, then empty sub-patterns will be deleted from the list. If \code{drop=FALSE} then they are retained. The argument \code{un} determines how to handle marks in the case where \code{x} is a marked point pattern. If \code{un=TRUE} then the marks of the points will be discarded when they are split into groups, while if \code{un=FALSE} then the marks will be retained. If \code{f} and \code{un} are both missing, then the default is \code{un=TRUE} for multitype point patterns and \code{un=FALSE} for marked point patterns with a data frame of marks. If the marks of \code{x} are a data frame, then \code{split(x, reduce=TRUE)} will discard only the column of marks that was used to split the pattern. This applies only when the argument \code{f} is missing. The result of \code{split.ppp} has class \code{"splitppp"} and can be plotted using \code{\link{plot.splitppp}}. The assignment function \code{split<-.ppp} updates the point pattern \code{x} so that it satisfies \code{split(x, f, drop, un) = value}. The argument \code{value} is expected to be a list of point patterns, one for each level of \code{f}. These point patterns are expected to be compatible with the type of data in the original pattern \code{x}. Splitting can also be undone by the function \code{\link{superimpose}}, but this typically changes the ordering of the data. } \seealso{ \code{\link{cut.ppp}}, \code{\link{plot.splitppp}}, \code{\link{superimpose}}, \code{\link{im}}, \code{\link{tess}}, \code{\link{ppp.object}} } \examples{ # (1) Splitting by marks # Multitype point pattern: separate into types u <- split(amacrine) # plot them plot(split(amacrine)) # the following are equivalent: amon <- split(amacrine)$on amon <- unmark(amacrine[amacrine$marks == "on"]) amon <- subset(amacrine, marks == "on", -marks) # the following are equivalent: amon <- split(amacrine, un=FALSE)$on amon <- amacrine[amacrine$marks == "on"] # Scramble the locations of the 'on' cells X <- amacrine u <- split(X) u$on <- runifrect(npoints(amon), Window(amon)) split(X) <- u # Point pattern with continuous marks trees <- longleaf \testonly{ # smaller dataset trees <- trees[seq(1, npoints(trees), by=80)] } # cut the range of tree diameters into three intervals # using cut.ppp long3 <- cut(trees, breaks=3) # now split them long3split <- split(long3) # (2) Splitting by a factor # Unmarked point pattern swedishpines # cut & split according to nearest neighbour distance f <- cut(nndist(swedishpines), 3) u <- split(swedishpines, f) # (3) Splitting over a tessellation tes <- tess(xgrid=seq(0,96,length=5),ygrid=seq(0,100,length=5)) v <- split(swedishpines, tes) # (4) how to apply an operation to selected points: # split into components, transform desired component, then un-split # e.g. apply random jitter to 'on' points only X <- amacrine Y <- split(X) Y$on <- rjitter(Y$on, 0.1) split(X) <- Y } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} \keyword{manip} spatstat.geom/man/as.data.frame.psp.Rd0000644000176200001440000000250414611065345017320 0ustar liggesusers\name{as.data.frame.psp} \alias{as.data.frame.psp} \title{Coerce Line Segment Pattern to a Data Frame} \description{ Extracts the coordinates of the endpoints in a line segment pattern, and their marks if any, and returns them in a data frame. } \usage{ \method{as.data.frame}{psp}(x, row.names = NULL, ...) } \arguments{ \item{x}{Line segment pattern (object of class \code{"psp"}).} \item{row.names}{Optional character vector of row names.} \item{\dots}{Ignored.} } \details{ This is a method for the generic function \code{\link{as.data.frame}} for the class \code{"psp"} of line segment patterns. It extracts the coordinates of the endpoints of the line segments, and returns them as columns named \code{x0}, \code{y0}, \code{x1} and \code{y1} in a data frame. If the line segments were marked, the marks are appended as an extra column or columns to the data frame which is returned. If the marks are a vector then a single column named \code{marks} is appended. in the data frame, with the same type as in the line segment pattern dataset. If the marks are a data frame, then the columns of this data frame are appended (retaining their names). } \value{ A data frame with 4 or 5 columns. } \examples{ df <- as.data.frame(copper$Lines) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/plot.hyperframe.Rd0000644000176200001440000000666114611065347017244 0ustar liggesusers\name{plot.hyperframe} \alias{plot.hyperframe} \title{Plot Entries in a Hyperframe} \description{ Plots the entries in a hyperframe, in a series of panels, one panel for each row of the hyperframe. } \usage{ \method{plot}{hyperframe}(x, e, \dots, main, arrange=TRUE, nrows=NULL, ncols=NULL, parargs=list(mar=mar * marsize), marsize=1, mar=c(1,1,3,1)) } \arguments{ \item{x}{ Data to be plotted. A hyperframe (object of class \code{"hyperframe"}, see \code{\link{hyperframe}}). } \item{e}{ How to plot each row. Optional. An \R language call or expression (typically enclosed in \code{\link{quote}()} that will be evaluated in each row of the hyperframe to generate the plots. } \item{\dots}{ Extra arguments controlling the plot (when \code{e} is missing). } \item{main}{Overall title for the array of plots.} \item{arrange}{ Logical flag indicating whether to plot the objects side-by-side on a single page (\code{arrange=TRUE}) or plot them individually in a succession of frames (\code{arrange=FALSE}). } \item{nrows,ncols}{ Optional. The number of rows/columns in the plot layout (assuming \code{arrange=TRUE}). You can specify either or both of these numbers. } \item{parargs}{ Optional list of arguments passed to \code{\link{par}} before plotting each panel. Can be used to control margin sizes, etc. } \item{marsize}{ Optional scale parameter controlling the sizes of margins around the panels. Incompatible with \code{parargs}. } \item{mar}{ Optional numeric vector of length 1, 2 or 4 controlling the relative sizes of margins between the panels. Incompatible with \code{parargs}. } } \details{ This is the \code{plot} method for the class \code{"hyperframe"}. The argument \code{x} must be a hyperframe (like a data frame, except that the entries can be objects of any class; see \code{\link{hyperframe}}). This function generates a series of plots, one plot for each row of the hyperframe. If \code{arrange=TRUE} (the default), then these plots are arranged in a neat array of panels within a single plot frame. If \code{arrange=FALSE}, the plots are simply executed one after another. Exactly what is plotted, and how it is plotted, depends on the argument \code{e}. The default (if \code{e} is missing) is to plot only the first column of \code{x}. Each entry in the first column is plotted using the generic \code{\link{plot}} command, together with any extra arguments given in \code{\dots}. If \code{e} is present, it should be an \R language expression involving the column names of \code{x}. (It is typically created using \code{\link{quote}} or \code{\link{expression}}.) The expression will be evaluated once for each row of \code{x}. It will be evaluated in an environment where each column name of \code{x} is interpreted as meaning the object in that column in the current row. See the Examples. } \value{ \code{NULL}. } \seealso{ \code{\link{hyperframe}}, \code{\link{with.hyperframe}} } \examples{ H <- hyperframe(id=1:6) H$X <- with(H, runifrect(100)) H$D <- with(H, distmap(X)) # points only plot(H[,"X"]) plot(H, quote(plot(X, main=id))) # points superimposed on images plot(H, quote({plot(D, main=id); plot(X, add=TRUE)})) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/ppx.Rd0000644000176200001440000000633514611065350014724 0ustar liggesusers\name{ppx} \Rdversion{1.1} \alias{ppx} \title{ Multidimensional Space-Time Point Pattern } \description{ Creates a multidimensional space-time point pattern with any kind of coordinates and marks. } \usage{ ppx(data, domain=NULL, coord.type=NULL, simplify=FALSE) } \arguments{ \item{data}{ The coordinates and marks of the points. A \code{data.frame} or \code{hyperframe}. } \item{domain}{ Optional. The space-time domain containing the points. An object in some appropriate format, or \code{NULL}. } \item{coord.type}{ Character vector specifying how each column of \code{data} should be interpreted: as a spatial coordinate, a temporal coordinate, a local coordinate or a mark. Entries are partially matched to the values \code{"spatial"}, \code{"temporal"}, \code{"local"} and \code{"mark"}. } \item{simplify}{ Logical value indicating whether to simplify the result in special cases. If \code{simplify=TRUE}, a two-dimensional point pattern will be returned as an object of class \code{"ppp"}, and a three-dimensional point pattern will be returned as an object of class \code{"pp3"}. If \code{simplify=FALSE} (the default) then the result is always an object of class \code{"ppx"}. } } \details{ An object of class \code{"ppx"} represents a marked point pattern in multidimensional space and/or time. There may be any number of spatial coordinates, any number of temporal coordinates, any number of local coordinates, and any number of mark variables. The individual marks may be atomic (numeric values, factor values, etc) or objects of any kind. The argument \code{data} should contain the coordinates and marks of the points. It should be a \code{data.frame} or more generally a \code{hyperframe} (see \code{\link{hyperframe}}) with one row of data for each point. Each column of \code{data} is either a spatial coordinate, a temporal coordinate, a local coordinate, or a mark variable. The argument \code{coord.type} determines how each column is interpreted. It should be a character vector, of length equal to the number of columns of \code{data}. It should contain strings that partially match the values \code{"spatial"}, \code{"temporal"}, \code{"local"} and \code{"mark"}. (The first letters will be sufficient.) By default (if \code{coord.type} is missing or \code{NULL}), columns of numerical data are assumed to represent spatial coordinates, while other columns are assumed to be marks. } \value{ Usually an object of class \code{"ppx"}. If \code{simplify=TRUE} the result may be an object of class \code{"ppp"} or \code{"pp3"}. } \author{\adrian and \rolf } \seealso{ \code{\link{pp3}}, \code{\link{print.ppx}} } \examples{ df <- data.frame(x=runif(4),y=runif(4),t=runif(4), age=rep(c("old", "new"), 2), size=runif(4)) X <- ppx(data=df, coord.type=c("s","s","t","m","m")) X #' one-dimensional points #' with marks which are two-dimensional point patterns val <- sample(10:20, 4) E <- lapply(val, runifrect) E hf <- hyperframe(num=val, e=as.listof(E)) Z <- ppx(data=hf, domain=c(10,20)) Z } \keyword{spatial} \keyword{datagen} spatstat.geom/man/methods.layered.Rd0000644000176200001440000000416714611065347017213 0ustar liggesusers\name{methods.layered} \Rdversion{1.1} \alias{methods.layered} %DoNotExport \alias{shift.layered} \alias{reflect.layered} \alias{flipxy.layered} \alias{rotate.layered} \alias{affine.layered} \alias{rescale.layered} \alias{scalardilate.layered} \title{ Methods for Layered Objects } \description{ Methods for geometrical transformations of layered objects (class \code{"layered"}). } \usage{ \method{shift}{layered}(X, vec=c(0,0), ...) \method{rotate}{layered}(X, ..., centre=NULL) \method{affine}{layered}(X, ...) \method{reflect}{layered}(X) \method{flipxy}{layered}(X) \method{rescale}{layered}(X, s, unitname) \method{scalardilate}{layered}(X, ...) } \arguments{ \item{X}{ Object of class \code{"layered"}. } \item{\dots}{ Arguments passed to the relevant methods when applying the operation to each layer of \code{X}. } \item{s}{ Rescaling factor passed to the relevant method for \code{\link{rescale}}. May be missing. } \item{vec}{ Shift vector (numeric vector of length 2). } \item{centre}{ Centre of rotation. Either a vector of length 2, or a character string (partially matched to \code{"centroid"}, \code{"midpoint"} or \code{"bottomleft"}). The default is the coordinate origin \code{c(0,0)}. } \item{unitname}{ Optional. New name for the unit of length. A value acceptable to the function \code{\link{unitname<-}} } } \details{ These are methods for the generic functions \code{\link{shift}}, \code{\link{rotate}}, \code{\link{reflect}}, \code{\link{affine}}, \code{\link{rescale}}, \code{\link{scalardilate}} and \code{\link{flipxy}} for the class of layered objects. A layered object represents data that should be plotted in successive layers, for example, a background and a foreground. See \code{\link{layered}}. } \value{ Another object of class \code{"layered"}. } \author{\adrian and \rolf } \seealso{ \code{\link{layered}} } \examples{ B <- owin(c(5500, 9000), c(2500, 7400)) L <- layered(Window(demopat), unmark(demopat)[B]) plot(L) plot(rotate(L, pi/4)) } \keyword{spatial} \keyword{methods} spatstat.geom/man/areaLoss.Rd0000644000176200001440000000403714611065345015667 0ustar liggesusers\name{areaLoss} \alias{areaLoss} \title{Difference of Disc Areas} \description{ Computes the area of that part of a disc that is not covered by other discs. } \usage{ areaLoss(X, r, ..., W=as.owin(X), subset=NULL, exact=FALSE, ngrid=spatstat.options("ngrid.disc")) } \arguments{ \item{X}{ Locations of the centres of discs. A point pattern (object of class \code{"ppp"}). } \item{r}{ Disc radius, or vector of disc radii. } \item{\dots}{Ignored.} \item{W}{ Optional. Window (object of class \code{"owin"}) inside which the area should be calculated. } \item{subset}{ Optional. Index identifying a subset of the points of \code{X} for which the area difference should be computed. } \item{exact}{ Choice of algorithm. If \code{exact=TRUE}, areas are computed exactly using analytic geometry. If \code{exact=FALSE} then a faster algorithm is used to compute a discrete approximation to the areas. } \item{ngrid}{ Integer. Number of points in the square grid used to compute the discrete approximation, when \code{exact=FALSE}. } } \value{ A matrix with one row for each point in \code{X} (or \code{X[subset]}) and one column for each value in \code{r}. } \details{ This function computes, for each point \code{X[i]} in \code{X} and for each radius \code{r}, the area of that part of the disc of radius \code{r} centred at the location \code{X[i]} that is \emph{not} covered by any of the other discs of radius \code{r} centred at the points \code{X[j]} for \code{j} not equal to \code{i}. This area is important in some calculations related to the area-interaction model \code{\link[spatstat.model]{AreaInter}}. The result is a matrix, with one row for each point in \code{X} and one column for each entry of \code{r}. } \seealso{ \code{\link[spatstat.model]{AreaInter}}, \code{\link{areaGain}}, \code{\link{dilated.areas}} } \examples{ areaLoss(cells, 0.1) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/plot.texturemap.Rd0000644000176200001440000000607014722270274017272 0ustar liggesusers\name{plot.texturemap} \alias{plot.texturemap} \title{ Plot a Texture Map } \description{ Plot a representation of a texture map, similar to a plot legend. } \usage{ \method{plot}{texturemap}(x, \dots, main, xlim = NULL, ylim = NULL, vertical = FALSE, axis = TRUE, side = if(vertical) "right" else "bottom", labelmap = NULL, gap = 0.25, spacing = NULL, add = FALSE) } \arguments{ \item{x}{ Texture map object (class \code{"texturemap"}). } \item{\dots}{ Additional graphics arguments passed to \code{\link{add.texture}} or \code{\link[graphics]{axis}}. } \item{main}{ Main title for plot. } \item{xlim,ylim}{ Optional vectors of length 2 giving the \eqn{x} and \eqn{y} limits of the plot. } \item{vertical}{ Logical value indicating whether to arrange the texture boxes in a vertical column (\code{vertical=TRUE} or a horizontal row (\code{vertical=FALSE}, the default). } \item{axis}{ Logical value indicating whether to plot axis-style labels next to the texture boxes. } \item{side}{ One of the character strings \code{"bottom"}, \code{"left"}, \code{"top"} or \code{"right"}, or one of the integers from 1 to 4, specifying the position of the axis-style labels, if \code{axis=TRUE}. } \item{labelmap}{ Optional. A \code{function} which will be applied to the data values (the inputs of the texture map) before they are displayed on the plot. } \item{gap}{ Separation between texture boxes, as a fraction of the width or height of a box. } \item{spacing}{ Argument passed to \code{\link{add.texture}} controlling the density of lines in a texture. Expressed in spatial coordinate units. } \item{add}{ Logical value indicating whether to add the graphics to an existing plot (\code{add=TRUE}) or to initialise a new plot (\code{add=FALSE}, the default). } } \details{ A texture map is an association between data values and graphical textures. An object of class \code{"texturemap"} represents a texture map. Such objects are returned from the plotting function \code{\link{textureplot}}, and can be created directly by the function \code{\link{texturemap}}. This function \code{plot.texturemap} is a method for the generic \code{\link{plot}} for the class \code{"texturemap"}. It displays a sample of each of the textures in the texture map, in a separate box, annotated by the data value which is mapped to that texture. The arrangement and position of the boxes is controlled by the arguments \code{vertical}, \code{xlim}, \code{ylim} and \code{gap}. } \value{ Null. } \author{\adrian \rolf and \ege } \seealso{ \code{\link{texturemap}}, \code{\link{textureplot}}, \code{\link{add.texture}}. } \examples{ tm <- texturemap(c("First", "Second", "Third"), 2:4, col=2:4) plot(tm, vertical=FALSE) ## abbreviate the labels plot(tm, labelmap=function(x) substr(x, 1, 2)) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/pointsOnLines.Rd0000644000176200001440000000336614611065350016722 0ustar liggesusers\name{pointsOnLines} \alias{pointsOnLines} \title{Place Points Evenly Along Specified Lines} \description{ Given a line segment pattern, place a series of points at equal distances along each line segment. } \usage{ pointsOnLines(X, eps = NULL, np = 1000, shortok=TRUE) } \arguments{ \item{X}{A line segment pattern (object of class \code{"psp"}).} \item{eps}{Spacing between successive points.} \item{np}{Approximate total number of points (incompatible with \code{eps}).} \item{shortok}{ Logical. If \code{FALSE}, very short segments (of length shorter than \code{eps}) will not generate any points. If \code{TRUE}, a very short segment will be represented by its midpoint. } } \details{ For each line segment in the pattern \code{X}, a succession of points is placed along the line segment. These points are equally spaced at a distance \code{eps}, except for the first and last points in the sequence. The spacing \code{eps} is measured in coordinate units of \code{X}. If \code{eps} is not given, then it is determined by \code{eps = len/np} where \code{len} is the total length of the segments in \code{X}. The actual number of points will then be slightly larger than \code{np}. } \value{ A point pattern (object of class \code{"ppp"}) in the same window as \code{X}. The result also has an attribute called \code{"map"} which maps the points to their parent line segments. } \seealso{ \code{\link{psp}}, \code{\link{ppp}}, \code{\link[spatstat.random]{runifpointOnLines}} } \examples{ X <- psp(runif(20), runif(20), runif(20), runif(20), window=owin()) Y <- pointsOnLines(X, eps=0.05) plot(X, main="") plot(Y, add=TRUE, pch="+") } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/plot.ppp.Rd0000644000176200001440000004454314723232636015703 0ustar liggesusers\name{plot.ppp} \alias{plot.ppp} \title{plot a Spatial Point Pattern} \description{ Plot a two-dimensional spatial point pattern } \usage{ \method{plot}{ppp}(x, main, \dots, clipwin=NULL, chars=NULL, cols=NULL, use.marks=TRUE, which.marks=NULL, add=FALSE, type=c("p","n"), legend=TRUE, leg.side=c("left", "bottom", "top", "right"), leg.args=list(), symap=NULL, maxsize=NULL, meansize=NULL, markscale=NULL, minsize=NULL, zerosize=NULL, zap=0.01, show.window=show.all, show.all=!add, do.plot=TRUE, multiplot=TRUE) } \arguments{ \item{x}{ The spatial point pattern to be plotted. An object of class \code{"ppp"}, or data which can be converted into this format by \code{\link{as.ppp}()}. } \item{main}{ text to be displayed as a title above the plot. } \item{\dots}{ extra arguments that will be passed to the plotting functions \code{\link{plot.default}}, \code{\link{points}} and/or \code{\link{symbols}}. Not all arguments will be recognised. } \item{clipwin}{ Optional. A window (object of class \code{"owin"}). Only this subset of the image will be displayed. } \item{chars}{ the plotting character(s) used to plot points. Either a single character, an integer, or a vector of single characters or integers. Ignored if \code{symap} is given. } \item{cols}{ the colour(s) used to plot points. Either an integer index from 1 to 8 (indexing the standard colour palette), a character string giving the name of a colour, or a string giving the hexadecimal representation of a colour, or a vector of such integers or strings. See the section on \emph{Colour Specification} in the help for \code{\link[graphics]{par}}. Ignored if \code{symap} is given. } \item{use.marks}{ logical flag; if \code{TRUE}, plot points using a different plotting symbol for each mark; if \code{FALSE}, only the locations of the points will be plotted, using \code{\link{points}()}. } \item{which.marks}{ Index determining which column of marks to use, if the marks of \code{x} are a data frame. A character or integer vector identifying one or more columns of marks. If \code{add=FALSE} then the default is to plot all columns of marks, in a series of separate plots. If \code{add=TRUE} then only one column of marks can be plotted, and the default is \code{which.marks=1} indicating the first column of marks. } \item{add}{ logical flag; if \code{TRUE}, just the points are plotted, over the existing plot. A new plot is not created, and the window is not plotted. } \item{type}{ Type of plot: either \code{"p"} or \code{"n"}. If \code{type="p"} (the default), both the points and the observation window are plotted. If \code{type="n"}, only the window is plotted. } \item{legend}{ Logical value indicating whether to add a legend showing the mapping between mark values and graphical symbols (for a marked point pattern). } \item{leg.side}{ Position of legend relative to main plot. } \item{leg.args}{ List of additional arguments passed to \code{\link{plot.symbolmap}} or \code{\link{symbolmap}} to control the legend. In addition to arguments documented under \code{\link{plot.symbolmap}}, and graphical arguments recognised by \code{\link{symbolmap}}, the list may also include the argument \code{sep} giving the separation between the main plot and the legend, or \code{sep.frac} giving the separation as a fraction of the largest dimension (maximum of width and height) of the main plot. } \item{symap}{ The graphical symbol map to be applied to the marks. An object of class \code{"symbolmap"}; see \code{\link{symbolmap}}. } \item{maxsize}{ \emph{Maximum} physical size of the circles/squares plotted when \code{x} is a marked point pattern with numerical marks. Incompatible with \code{meansize} and \code{markscale}. Ignored if \code{symap} is given. } \item{meansize}{ \emph{Average} physical size of the circles/squares plotted when \code{x} is a marked point pattern with numerical marks. Incompatible with \code{maxsize} and \code{markscale}. Ignored if \code{symap} is given. } \item{markscale}{ physical scale factor determining the sizes of the circles/squares plotted when \code{x} is a marked point pattern with numerical marks. Mark value will be multiplied by \code{markscale} to determine physical size. Incompatible with \code{maxsize} and \code{meansize}. Ignored if \code{symap} is given. } \item{minsize}{ \emph{Minimum} physical size of the circles/squares plotted when \code{x} is a marked point pattern with numerical marks. Incompatible with \code{zerosize}. Ignored if \code{symap} is given. } \item{zerosize}{ Physical size of the circle/square representing a mark value of zero, when \code{x} is a marked point pattern with numerical marks. Incompatible with \code{minsize}. Defaults to zero. Ignored if \code{symap} is given. } \item{zap}{ Fraction between 0 and 1. When \code{x} is a marked point pattern with numerical marks, \code{zap} is the smallest mark value (expressed as a fraction of the maximum possible mark) that will be plotted. Any points which have marks smaller in absolute value than \code{zap * max(abs(marks(x)))} will not be plotted. } \item{show.window}{ Logical value indicating whether to plot the observation window of \code{x}. } \item{show.all}{ Logical value indicating whether to plot everything including the main title and the observation window of \code{x}. } \item{do.plot}{ Logical value determining whether to actually perform the plotting. } \item{multiplot}{ Logical value giving permission to display multiple plots. } } \value{ (Invisible) object of class \code{"symbolmap"} giving the correspondence between mark values and plotting characters. } \details{ This is the \code{plot} method for point pattern datasets (of class \code{"ppp"}, see \code{\link{ppp.object}}). First the observation window \code{Window(x)} is plotted (if \code{show.window=TRUE}). Then the points themselves are plotted, in a fashion that depends on their marks, as follows. \describe{ \item{unmarked point pattern:}{ If the point pattern does not have marks, or if \code{use.marks = FALSE}, then the locations of all points will be plotted using a single plot character } \item{multitype point pattern:}{ If \code{marks(x)} is a factor, then each level of the factor is represented by a different plot character. } \item{continuous marks:}{ If \code{marks(x)} is a numeric vector, the marks are rescaled to the unit interval and each point is represented by a circle with \emph{diameter} proportional to the rescaled mark (if the value is positive) or a square with \emph{side length} proportional to the absolute value of the rescaled mark (if the value is negative). } \item{other kinds of marks:}{ If \code{marks(x)} is neither numeric nor a factor, then each possible mark will be represented by a different plotting character. The default is to represent the \eqn{i}th smallest mark value by \code{points(..., pch=i)}. } } If there are several columns of marks, and if \code{which.marks} is missing or \code{NULL}, then \itemize{ \item if \code{add=FALSE} and \code{multiplot=TRUE} the default is to plot all columns of marks, in a series of separate plots, placed side-by-side. The plotting is coordinated by \code{\link{plot.listof}}, which calls \code{plot.ppp} to make each of the individual plots. \item Otherwise, only one column of marks can be plotted, and the default is \code{which.marks=1} indicating the first column of marks. } Plotting of the window \code{Window(x)} is performed by \code{\link{plot.owin}}. This plot may be modified through the \code{...} arguments. In particular the extra argument \code{border} determines the colour of the window, if the window is not a binary mask. Plotting of the points themselves is performed by the function \code{\link{points}}, except for the case of continuous marks, where it is performed by \code{\link{symbols}}. Their plotting behaviour may be modified through the \code{...} arguments. If the argument \code{symap} is given, then it determines the graphical display of the points. It should be a symbol map (object of class \code{"symbolmap"}) created by the function \code{\link{symbolmap}}. If \code{symap} is not given, then the following arguments can be used to specify how the points are plotted: \itemize{ \item The argument \code{chars} determines the plotting character or characters used to display the points (in all cases except for the case of continuous marks). For an unmarked point pattern, this should be a single integer or character determining a plotting character (see \code{par("pch")}). For a multitype point pattern, \code{chars} should be a vector of integers or characters, of the same length as \code{levels(marks(x))}, and then the \eqn{i}th level or type will be plotted using character \code{chars[i]}. \item If \code{chars} is absent, but there is an extra argument \code{pch}, then this will determine the plotting character for all points. \item The argument \code{cols} determines the colour or colours used to display the points. For an unmarked point pattern, \code{cols} should be a character string determining a colour. For a multitype point pattern, \code{cols} should be a character vector, of the same length as \code{levels(marks(x))}: that is, there is one colour for each possible mark value. The \eqn{i}th level or type will be plotted using colour \code{cols[i]}. For a point pattern with continuous marks, \code{cols} can be either a character string or a character vector specifying colour values: the range of mark values will be mapped to the specified colours. \item If \code{cols} is absent, the colours used to plot the points may be determined by the extra argument \code{fg} (for multitype point patterns) or the extra argument \code{col} (for all other cases). Note that specifying \code{col} will also apply this colour to the window itself. \item The default colour for the points is a semi-transparent grey, if this is supported by the plot device. This behaviour can be suppressed (so that the default colour is non-transparent) by setting \code{spatstat.options(transparent=FALSE)}. \item The arguments \code{maxsize}, \code{meansize} and \code{markscale} are incompatible with each other (and incompatible with \code{symap}). The arguments \code{minsize} and \code{zerosize} are incompatible with each other (and incompatible with \code{symap}). Together, these arguments control the physical size of the circles and squares which represent the marks in a point pattern with continuous marks. The size of a circle is defined as its \emph{diameter}; the size of a square is its side length. If \code{markscale} is given, then a mark value of \code{m} is plotted as a circle of diameter \code{m * markscale + zerosize} (if \code{m} is positive) or a square of side \code{abs(m) * markscale + zerosize} (if \code{m} is negative). If \code{maxsize} is given, then the largest mark in absolute value, \code{mmax=max(abs(marks(x)))}, will be scaled to have physical size \code{maxsize}. If \code{meansize} is given, then the average absolute mark value, \code{mmean=mean(abs(marks(x)))}, will be scaled to have physical size \code{meansize}. If \code{minsize} is given, then the minimum mark value, \code{mmean=mean(abs(marks(x)))}, will be scaled to have physical size \code{minsize}. \item The user can set the default values of these plotting parameters using \code{\link{spatstat.options}("par.points")}. } To zoom in (to view only a subset of the point pattern at higher magnification), use the graphical arguments \code{xlim} and \code{ylim} to specify the rectangular field of view. The value returned by this plot function is an object of class \code{"symbolmap"} representing the mapping from mark values to graphical symbols. See \code{\link{symbolmap}}. It can be used to make a suitable legend, or to ensure that two plots use the same graphics map. } \section{Layout of the plot}{ \itemize{ \item \bold{Placement of main title:} The left-right placement of the main title is controlled by the argument \code{adj.main} passed to \code{\link[spatstat.geom]{plot.owin}}. To remove the main title, set \code{main=""}. \item \bold{Removing White Space Around The Plot:} A frequently-asked question is: How do I remove the white space around the plot? Currently \code{plot.ppp} uses the base graphics system of \R, so the space around the plot is controlled by parameters to \code{\link{par}}. To reduce the white space, change the parameter \code{mar}. Typically, \code{par(mar=rep(0.5, 4))} is adequate, if there are no annotations or titles outside the window. \item \bold{Drawing coordinate axes and axis labels:} Coordinate axes and axis labels are not drawn, by default. To draw coordinate axes, set \code{axes=TRUE}. To draw axis labels, set \code{ann=TRUE} and give values to the arguments \code{xlab} and \code{ylab}. See the Examples. Only the default style of axis is supported; for more control over the placement and style of axes, use the graphics commands \code{\link[graphics]{axis}} and \code{\link[graphics]{mtext}}. } } \section{The Symbol Map}{ The behaviour of \code{plot.ppp} is different from the behaviour of the base \R graphics functions \code{\link[graphics]{points}} and \code{\link[graphics]{symbols}}. In the base graphics functions \code{\link[graphics]{points}} and \code{\link[graphics]{symbols}}, arguments such as \code{col}, \code{pch} and \code{cex} can be vectors which specify the \emph{representation of each successive point}. For example \code{col[3]} would specify the colour of the third point in the sequence of points. If there are 100 points then \code{col} should be a vector of length 100. In the \pkg{spatstat} function \code{plot.ppp}, arguments such as \code{col}, \code{pch} and \code{cex} specify the \emph{mapping from point characteristics to graphical parameters} (called the symbol map). For example \code{col[3]} specifies the colour of the third \bold{type of point} in a pattern of points of different types. If there are 4 types of points then \code{col} should be a vector of length 4. To modify a symbol map, for example to change the colours used without changing anything else, use \code{\link{update.symbolmap}}. } \seealso{ \code{\link{ppp.object}}, \code{\link{plot}}, \code{\link{par}}, \code{\link{points}}, \code{\link{text.ppp}}, \code{\link{plot.owin}}, \code{\link{symbols}}. See also the command \code{iplot} in the \pkg{spatstat.gui} package. } \examples{ plot(cells) plot(cells, pch=16) # make the plotting symbols larger (for publication at reduced scale) plot(cells, cex=2) # set it in spatstat.options oldopt <- spatstat.options(par.points=list(cex=2)) plot(cells) spatstat.options(oldopt) # multitype plot(lansing) # marked by a real number plot(longleaf) # just plot the points plot(longleaf, use.marks=FALSE) plot(unmark(longleaf)) # equivalent # point pattern with multiple marks plot(finpines) plot(finpines, which.marks="height") # controlling COLOURS of points plot(cells, cols="blue") plot(lansing, cols=c("black", "yellow", "green", "blue","red","pink")) plot(longleaf, fg="blue") # make window purple plot(lansing, border="purple") # make everything purple plot(lansing, border="purple", cols="purple", col.main="purple", leg.args=list(col.axis="purple")) # controlling PLOT CHARACTERS for multitype pattern plot(lansing, chars = 11:16) plot(lansing, chars = c("o","h","m",".","o","o")) ## multitype pattern mapped to symbols plot(amacrine, shape=c("circles", "squares"), size=0.04) plot(amacrine, shape="arrows", direction=c(0,90), size=0.07) ## plot trees as trees! plot(lansing, shape="arrows", direction=90, cols=1:6) # controlling MARK SCALE for pattern with numeric marks plot(longleaf, markscale=0.1) plot(longleaf, maxsize=5) plot(longleaf, meansize=2) plot(longleaf, minsize=2) # draw circles of diameter equal to nearest neighbour distance plot(cells \%mark\% nndist(cells), markscale=1, legend=FALSE) # inspecting the symbol map v <- plot(amacrine) v ## variable colours ('cols' not 'col') plot(longleaf, cols=function(x) ifelse(x < 30, "red", "black")) ## re-using the same mark scale a <- plot(longleaf) juveniles <- longleaf[marks(longleaf) < 30] plot(juveniles, symap=a) ## numerical marks mapped to symbols of fixed size with variable colour ra <- range(marks(longleaf)) colmap <- colourmap(terrain.colors(20), range=ra) ## filled plot characters are the codes 21-25 ## fill colour is indicated by 'bg' ## outline colour is 'fg' sy <- symbolmap(pch=21, bg=colmap, fg=colmap, range=ra) plot(longleaf, symap=sy) ## or more compactly.. plot(longleaf, bg=terrain.colors(20), pch=21, cex=1) ## plot only the colour map (since the symbols have fixed size and shape) plot(longleaf, symap=sy, leg.args=list(colour.only=TRUE)) ## clipping plot(humberside) B <- owin(c(4810, 5190), c(4180, 4430)) plot(B, add=TRUE, border="red") plot(humberside, clipwin=B, main="Humberside (clipped)") ## coordinate axes and labels plot(humberside, axes=TRUE) plot(humberside, ann=TRUE, xlab="Easting", ylab="Northing") plot(humberside, axes=TRUE, ann=TRUE, xlab="Easting", ylab="Northing") } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/as.colourmap.Rd0000644000176200001440000000247014611065345016520 0ustar liggesusers\name{as.colourmap} \alias{as.colourmap} \alias{as.colourmap.colourmap} \alias{as.colourmap.symbolmap} \title{ Convert to Colour Map } \description{ Convert some other kind of data to a colour map. } \usage{ as.colourmap(x, \dots) \method{as.colourmap}{colourmap}(x, \dots) \method{as.colourmap}{symbolmap}(x, \dots, warn=TRUE) } \arguments{ \item{x}{ Data to be converted to a colour map. An object of class \code{"symbolmap"}, \code{"colourmap"} or some other kind of suitable data. } \item{\dots}{ Other arguments passed to methods. } \item{warn}{ Logical value specifying whether to issue a warning if \code{x} does not contain any colour map information. } } \details{ If \code{x} contains colour map information, it will be extracted and returned as a colour map object. Otherwise, \code{NULL} will be returned (and a warning will be issued if \code{warn=TRUE}, the default). } \value{ A colour map (object of class \code{"colourmap"}) or \code{NULL}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{colourmap}} } \examples{ m <- pHcolourmap(c(3,8)) g <- symbolmap(pch=21, bg=m, size=function(x){ 1.1 * x }, range=c(3,8)) opa <- par(mfrow=c(1,2)) plot(g, vertical=TRUE) plot(as.colourmap(g), vertical=TRUE) par(opa) } \keyword{spatial} \keyword{color} spatstat.geom/man/nearestsegment.Rd0000644000176200001440000000305614611065347017144 0ustar liggesusers\name{nearestsegment} \alias{nearestsegment} \title{Find Line Segment Nearest to Each Point} \description{ Given a point pattern and a line segment pattern, this function finds the nearest line segment for each point. } \usage{ nearestsegment(X, Y) } \arguments{ \item{X}{A point pattern (object of class \code{"ppp"}).} \item{Y}{A line segment pattern (object of class \code{"psp"}).} } \details{ The distance between a point \code{x} and a straight line segment \code{y} is defined to be the shortest Euclidean distance between \code{x} and any location on \code{y}. This algorithm first calculates the distance from each point of \code{X} to each segment of \code{Y}. Then it determines, for each point \code{x} in \code{X}, which segment of \code{Y} is closest. The index of this segment is returned. } \value{ Integer vector \code{v} (of length equal to the number of points in \code{X}) identifying the nearest segment to each point. If \code{v[i] = j}, then \code{Y[j]} is the line segment lying closest to \code{X[i]}. } \author{ \adrian and \rolf } \seealso{ \code{\link{project2segment}} to project each point of \code{X} to a point lying on one of the line segments. Use \code{\link{distmap.psp}} to identify the nearest line segment for each pixel in a grid. } \examples{ X <- runifrect(3) Y <- as.psp(matrix(runif(20), 5, 4), window=owin()) v <- nearestsegment(X,Y) plot(Y) plot(X, add=TRUE) plot(X[1], add=TRUE, col="red") plot(Y[v[1]], add=TRUE, lwd=2, col="red") } \keyword{spatial} \keyword{math} spatstat.geom/man/harmonise.owin.Rd0000644000176200001440000000367714611065346017070 0ustar liggesusers\name{harmonise.owin} \alias{harmonise.owin} \alias{harmonize.owin} \title{Make Windows Compatible} \description{ Convert several windows to a common pixel raster. } \usage{ \method{harmonise}{owin}(\dots) \method{harmonize}{owin}(\dots) } \arguments{ \item{\dots}{ Any number of windows (objects of class \code{"owin"}) or data which can be converted to windows by \code{\link{as.owin}}. } } \details{ This function makes any number of windows compatible, by converting them all to a common pixel grid. This only has an effect if one of the windows is a binary mask. If all the windows are rectangular or polygonal, they are returned unchanged. The command \code{\link{harmonise}} is generic. This is the method for objects of class \code{"owin"}. Each argument must be a window (object of class \code{"owin"}), or data that can be converted to a window by \code{\link{as.owin}}. The common pixel grid is determined by inspecting all the windows in the argument list, computing the bounding box of all the windows, then finding the binary mask with the finest spatial resolution, and extending its pixel grid to cover the bounding box. The return value is a list with entries corresponding to the input arguments. If the arguments were named (\code{name=value}) then the return value also carries these names. If you just want to determine the appropriate pixel resolution, without converting the windows, use \code{\link{commonGrid}}. } \value{ A list of windows, of length equal to the number of arguments \code{\dots}. The list belongs to the class \code{"solist"}. } \author{\adrian and \rolf } \examples{ harmonise(X=letterR, Y=grow.rectangle(Frame(letterR), 0.2), Z=as.mask(letterR, eps=0.1), V=as.mask(letterR, eps=0.07)) } \seealso{ \code{\link{commonGrid}}, \code{\link{harmonise.im}}, \code{\link{as.owin}} } \keyword{spatial} \keyword{manip} spatstat.geom/man/reflect.Rd0000644000176200001440000000223414611065350015533 0ustar liggesusers\name{reflect} \alias{reflect} \alias{reflect.im} \alias{reflect.default} \title{Reflect In Origin} \description{ Reflects a geometrical object through the origin. } \usage{ reflect(X) \method{reflect}{im}(X) \method{reflect}{default}(X) } \arguments{ \item{X}{Any suitable dataset representing a two-dimensional object, such as a point pattern (object of class \code{"ppp"}), or a window (object of class \code{"owin"}).} } \value{ Another object of the same type, representing the result of reflection. } \details{ The object \code{X} is reflected through the origin. That is, each point in \code{X} with coordinates \eqn{(x,y)} is mapped to the position \eqn{(-x, -y)}. This is equivalent to applying the affine transformation with matrix \code{diag(c(-1,-1))}. It is also equivalent to rotation about the origin by 180 degrees. The command \code{reflect} is generic, with a method for pixel images and a default method. } \seealso{ \code{\link{affine}}, \code{\link{flipxy}} } \examples{ plot(reflect(as.im(letterR))) plot(reflect(letterR), add=TRUE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/text.ppp.Rd0000644000176200001440000000276614611065351015704 0ustar liggesusers\name{text.ppp} \alias{text.ppp} \alias{text.psp} \title{ Add Text Labels to Spatial Pattern } \description{ Plots a text label at the location of each point in a spatial point pattern, or each object in a spatial pattern of objects. } \usage{ \method{text}{ppp}(x, \dots) \method{text}{psp}(x, \dots) } \arguments{ \item{x}{ A spatial point pattern (object of class \code{"ppp"}), or a spatial pattern of line segments (class \code{"psp"}). } \item{\dots}{ Additional arguments passed to \code{\link[graphics]{text.default}}. } } \details{ These functions are methods for the generic \code{\link{text}}. A text label is added to the existing plot, at the location of each point in the point pattern \code{x}, or near the location of the midpoint of each segment in the segment pattern \code{x}. Additional arguments \code{\dots} are passed to \code{\link[graphics]{text.default}} and may be used to control the placement of the labels relative to the point locations, and the size and colour of the labels. By default, the labels are the serial numbers 1 to \code{n}, where \code{n} is the number of points or segments in \code{x}. This can be changed by specifying the argument \code{labels}, which should be a vector of length \code{n}. } \value{ Null. } \author{ \spatstatAuthors. } \seealso{ \code{\link[graphics]{text.default}} } \examples{ plot(cells) text(cells, pos=2) plot(Frame(cells)) text(cells, cex=1.5) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/convexhull.xy.Rd0000644000176200001440000000236514611065345016746 0ustar liggesusers\name{convexhull.xy} \alias{convexhull.xy} \title{Convex Hull of Points} \description{ Computes the convex hull of a set of points in two dimensions. } \usage{ convexhull.xy(x, y=NULL) } \arguments{ \item{x}{ vector of \code{x} coordinates of observed points, or a 2-column matrix giving \code{x,y} coordinates, or a list with components \code{x,y} giving coordinates (such as a point pattern object of class \code{"ppp"}.) } \item{y}{(optional) vector of \code{y} coordinates of observed points, if \code{x} is a vector.} } \value{ A window (an object of class \code{"owin"}). } \details{ Given an observed pattern of points with coordinates given by \code{x} and \code{y}, this function computes the convex hull of the points, and returns it as a window. } \seealso{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{convexhull}}, \code{\link{bounding.box.xy}}, \code{\link{ripras}} } \examples{ x <- runif(30) y <- runif(30) w <- convexhull.xy(x,y) plot(owin(), main="convexhull.xy(x,y)", lty=2) plot(w, add=TRUE) points(x,y) X <- runifrect(30) plot(X, main="convexhull.xy(X)") plot(convexhull.xy(X), add=TRUE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{utilities} spatstat.geom/man/plot.owin.Rd0000644000176200001440000002202314614356475016054 0ustar liggesusers\name{plot.owin} \alias{plot.owin} \title{Plot a Spatial Window} \description{ Plot a two-dimensional window of observation for a spatial point pattern } \usage{ \method{plot}{owin}(x, main, add=FALSE, \dots, box, edge=0.04, type=c("w","n"), show.all=!add, hatch=FALSE, hatchargs=list(), invert=FALSE, do.plot=TRUE, claim.title.space=FALSE, use.polypath=TRUE, adj.main=0.5) } \arguments{ \item{x}{ The window to be plotted. An object of class \code{\link{owin}}, or data which can be converted into this format by \code{\link{as.owin}()}. } \item{main}{ text to be displayed as a title above the plot. } \item{add}{ logical flag: if \code{TRUE}, draw the window in the current plot; if \code{FALSE}, generate a new plot. } \item{\dots}{ extra arguments controlling the appearance of the plot. These arguments are passed to \code{\link[graphics]{polygon}} if \code{x} is a polygonal or rectangular window, or passed to \code{\link[graphics]{image.default}} if \code{x} is a binary mask. Some arguments are passed to \code{\link[graphics]{plot.default}}. See Details. } \item{box}{ logical flag; if \code{TRUE}, plot the enclosing rectangular box } \item{edge}{ nonnegative number; the plotting region will have coordinate limits that are \code{1 + edge} times as large as the limits of the rectangular box that encloses the pattern. } \item{type}{ Type of plot: either \code{"w"} or \code{"n"}. If \code{type="w"} (the default), the window is plotted. If \code{type="n"} and \code{add=TRUE}, a new plot is initialised and the coordinate system is established, but nothing is drawn. } \item{show.all}{ Logical value indicating whether to plot everything including the main title. } \item{hatch}{ logical flag; if \code{TRUE}, the interior of the window will be shaded by texture, such as a grid of parallel lines. } \item{hatchargs}{ List of arguments passed to \code{\link{add.texture}} to control the texture shading when \code{hatch=TRUE}. } \item{invert}{ logical flag; when the window is a binary pixel mask, the mask colours will be inverted if \code{invert=TRUE}. } \item{do.plot}{ Logical value indicating whether to actually perform the plot. } \item{claim.title.space}{ Logical value indicating whether extra space for the main title should be allocated when declaring the plot dimensions. Should be set to \code{FALSE} under normal conditions. } \item{use.polypath}{ Logical value indicating what graphics capabilities should be used to draw a polygon filled with colour when the polygon has holes. If \code{TRUE} (the default), then the polygon will be filled using \code{\link[graphics]{polypath}}, provided the graphics device supports this function. If \code{FALSE}, the polygon will be decomposed into simple closed polygons, which will be colour filled using \code{\link[graphics]{polygon}}. } \item{adj.main}{ Numeric value specifying the justification of the text in the main title. Possible values are \code{adj.main=0.5} (the default) specifying that the main title will be centred, \code{adj.main=0} specifying left-justified text, and \code{adj.main=1} specifying right-justified text. } } \value{ none. } \details{ This is the \code{plot} method for the class \code{\link{owin}}. The action is to plot the boundary of the window on the current plot device, using equal scales on the \code{x} and \code{y} axes. If the window \code{x} is of type \code{"rectangle"} or \code{"polygonal"}, the boundary of the window is plotted as a polygon or series of polygons. If \code{x} is of type \code{"mask"} the discrete raster approximation of the window is displayed as a binary image (white inside the window, black outside). Graphical parameters controlling the display (e.g. setting the colours) may be passed directly via the \code{...} arguments, or indirectly reset using \code{\link{spatstat.options}}. If \code{add=FALSE} (the default), the plot is initialised by calling the base graphics function \code{\link[graphics]{plot.default}} to create the plot area. By default, coordinate axes and axis labels are not plotted. To plot coordinate axes, use the argument \code{axes=TRUE}; to plot axis labels, use the argument \code{ann=TRUE} and then specify the labels with \code{xlab} and \code{ylab}; see the help file for \code{\link[graphics]{plot.default}} for information on these arguments, and for additional arguments controlling the appearance of the axes. See the Examples also. When \code{x} is of type \code{"rectangle"} or \code{"polygonal"}, it is plotted by the \R function \code{\link[graphics]{polygon}}. To control the appearance (colour, fill density, line density etc) of the polygon plot, determine the required argument of \code{\link[graphics]{polygon}} and pass it through \code{...} For example, to paint the interior of the polygon in red, use the argument \code{col="red"}. To draw the polygon edges in green, use \code{border="green"}. To suppress the drawing of polygon edges, use \code{border=NA}. When \code{x} is of type \code{"mask"}, it is plotted by \code{\link[graphics]{image.default}}. The appearance of the image plot can be controlled by passing arguments to \code{\link[graphics]{image.default}} through \code{...}. The default appearance can also be changed by setting the parameter \code{par.binary} of \code{\link{spatstat.options}}. To zoom in (to view only a subset of the window at higher magnification), use the graphical arguments \code{xlim} and \code{ylim} to specify the desired rectangular field of view. (The actual field of view may be larger, depending on the graphics device). } \section{Notes on Filled Polygons with Holes}{ The function \code{\link[graphics]{polygon}} can only handle polygons without holes. To plot polygons with holes in a solid colour, we have implemented two workarounds. \describe{ \item{polypath function:}{ The first workaround uses the relatively new function \code{\link[graphics]{polypath}} which \emph{does} have the capability to handle polygons with holes. However, not all graphics devices support \code{\link[graphics]{polypath}}. The older devices \code{\link{xfig}} and \code{\link{pictex}} do not support \code{\link[graphics]{polypath}}. On a Windows system, the default graphics device #ifdef windows \code{\link{windows}} #endif #ifndef windows \code{windows} #endif supports \code{\link[graphics]{polypath}}. #ifdef unix On a Linux system, the default graphics device \code{X11(type="Xlib")} does \emph{not} support \code{\link[graphics]{polypath}} but \code{X11(type="cairo")} does support it. See \code{\link{X11}} and the section on Cairo below. #endif } \item{polygon decomposition:}{ The other workaround involves decomposing the polygonal window into pieces which do not have holes. This code is experimental but works in all our test cases. If this code fails, a warning will be issued, and the filled colours will not be plotted. } } } #ifdef unix \section{Cairo graphics on a Linux system}{ Linux systems support the graphics device \code{X11(type="cairo")} (see \code{\link{X11}}) provided the external library \pkg{cairo} is installed on the computer. See \code{www.cairographics.org} for instructions on obtaining and installing \pkg{cairo}. After having installed \pkg{cairo} one needs to re-install \R from source so that it has \pkg{cairo} capabilites. To check whether your current installation of R has \pkg{cairo} capabilities, type (in \R) \code{capabilities()["cairo"]}. The default type for \code{\link{X11}} is controlled by \code{\link[grDevices]{X11.options}}. You may find it convenient to make \pkg{cairo} the default, e.g. via your \code{.Rprofile}. The magic incantation to put into \code{.Rprofile} is \preformatted{ setHook(packageEvent("graphics", "onLoad"), function(...) grDevices::X11.options(type="cairo")) } } #endif \seealso{ \code{\link{owin.object}}, \code{\link{plot.ppp}}, \code{\link[graphics]{polygon}}, \code{\link[graphics]{image.default}}, \code{\link{spatstat.options}} } \examples{ # rectangular window plot(Window(nztrees)) abline(v=148, lty=2) # polygonal window w <- Window(demopat) plot(w) plot(w, col="red", border="green", lwd=2) plot(w, hatch=TRUE, lwd=2) # binary mask we <- as.mask(w) plot(we) op <- spatstat.options(par.binary=list(col=grey(c(0.5,1)))) plot(we) spatstat.options(op) ## axis annotation plot(letterR, axes=TRUE, ann=TRUE, xlab="Easting", ylab="Northing") plot(letterR, ann=TRUE, xlab="Declination", ylab="Right Ascension") } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/contour.imlist.Rd0000644000176200001440000000254414611065345017110 0ustar liggesusers\name{contour.imlist} \alias{contour.imlist} \alias{contour.listof} \title{Array of Contour Plots} \description{ Generates an array of contour plots. } \usage{ \method{contour}{imlist}(x, \dots) \method{contour}{listof}(x, \dots) } \arguments{ \item{x}{ An object of the class \code{"imlist"} representing a list of pixel images. Alternatively \code{x} may belong to the outdated class \code{"listof"}. } \item{\dots}{ Arguments passed to \code{\link{plot.solist}} to control the spatial arrangement of panels, and arguments passed to \code{\link{contour.im}} to control the display of each panel. } } \value{ Null. } \details{ This is a method for the generic command \code{contour} for the class \code{"imlist"}. An object of class \code{"imlist"} represents a list of pixel images. (The outdated class \code{"listof"} is also handled.) Each entry in the list \code{x} will be displayed as a contour plot, in an array of panels laid out on the same graphics display, using \code{\link{plot.solist}}. Invididual panels are plotted by \code{\link{contour.im}}. } \seealso{ \code{\link{plot.solist}}, \code{\link{contour.im}} } \examples{ # bei.extra is a named list of covariate images contour(bei.extra, main="Barro Colorado: covariates") } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/plot.textstring.Rd0000644000176200001440000000214114611065347017302 0ustar liggesusers\name{plot.textstring} \alias{plot.textstring} \title{Plot a Text String} \description{Plots an object of class \code{"textstring"}.} \usage{ \method{plot}{textstring}(x, \dots, do.plot = TRUE) } \arguments{ \item{x}{ Object of class \code{"textstring"} to be plotted. This object is created by the command \code{\link{textstring}}. } \item{\dots}{ Additional graphics arguments passed to \code{\link[graphics]{text}} to control the plotting of text. } \item{do.plot}{ Logical value indicating whether to actually plot the text. } } \details{ The argument \code{x} should be an object of class \code{"textstring"} created by the command \code{\link{textstring}}. This function displays the text using \code{\link[graphics]{text}}. } \value{ A window (class \code{"owin"}) enclosing the plotted graphics. } \examples{ W <- Window(humberside) te <- textstring(centroid.owin(W), txt="Humberside", cex=2.5) te plot(layered(W, te), main="") } \author{ \spatstatAuthors. } \seealso{ \code{\link{onearrow}}, \code{\link{yardstick}} } \keyword{spatial} \keyword{hplot} spatstat.geom/man/plot.quadratcount.Rd0000644000176200001440000000517314611065347017611 0ustar liggesusers\name{plot.quadratcount} \alias{plot.quadratcount} \title{ Plot Quadrat Counts } \description{ Given a table of quadrat counts for a spatial point pattern, plot the quadrats which were used, and display the quadrat count as text in the centre of each quadrat. } \usage{ \method{plot}{quadratcount}(x, \dots, add = FALSE, entries=as.integer(t(x)), dx = 0, dy = 0, show.tiles = TRUE, textargs = list()) } \arguments{ \item{x}{ Object of class \code{"quadratcount"} produced by the function \code{\link{quadratcount}}. } \item{\dots}{ Additional arguments passed to \code{\link{plot.tess}} to plot the quadrats. } \item{add}{ Logical. Whether to add the graphics to an existing plot. } \item{entries}{ Vector of numbers to be plotted in each quadrat. The default is to plot the quadrat counts. } \item{dx,dy}{ Horizontal and vertical displacement of text relative to centroid of quadrat. } \item{show.tiles}{ Logical value indicating whether to plot the quadrats. } \item{textargs}{ List containing extra arguments passed to \code{\link[graphics]{text.default}} to control the annotation. } } \details{ This is the plot method for the objects of class \code{"quadratcount"} that are produced by the function \code{\link{quadratcount}}. Given a spatial point pattern, \code{\link{quadratcount}} divides the observation window into disjoint tiles or quadrats, counts the number of points in each quadrat, and stores the result as a contingency table which also belongs to the class \code{"quadratcount"}. First the quadrats are plotted (provided \code{show.tiles=TRUE}, the default). This display can be controlled by passing additional arguments \code{\dots} to \code{\link{plot.tess}}. Then the quadrat counts are printed using \code{\link[graphics]{text.default}}. This display can be controlled using the arguments \code{dx,dy} and \code{textargs}. If \code{entries} is given, it should be a vector of length equal to the number of quadrats (the number of tiles in the tessellation \code{as.tess(x)}) containing integer or character values to be displayed in each quadrat, in the same sequence as \code{tiles(as.tess(x))} or \code{tilenames(as.tess(x))} or the counts in the transposed table \code{t(x)}. } \value{ Null. } \seealso{ \code{\link{quadratcount}}, \code{\link{plot.tess}}, \code{\link[graphics]{text.default}}, \code{\link[spatstat.explore]{plot.quadrattest}}. } \examples{ plot(quadratcount(swedishpines, 5)) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{hplot} spatstat.geom/man/extrapolate.psp.Rd0000644000176200001440000000244414611065346017250 0ustar liggesusers\name{extrapolate.psp} \alias{extrapolate.psp} \title{ Extrapolate Line Segments to Obtain Infinite Lines } \description{ Given a spatial pattern of line segments, extrapolate the segments to infinite lines. } \usage{ extrapolate.psp(x, \dots) } \arguments{ \item{x}{ Spatial pattern of line segments (object of class \code{"psp"}). } \item{\dots}{ Ignored. } } \details{ Each line segment in the pattern \code{x} is extrapolated to an infinite line, drawn through its two endpoints. The resulting pattern of infinite lines is returned as an object of class \code{"infline"}. If a segment's endpoints are identical (so that it has zero length) the resulting infinite line is vertical (i.e. parallel to the \eqn{y} coordinate axis). } \value{ An object of class \code{"infline"} representing the pattern of infinite lines. See \code{\link{infline}} for details of structure. } \author{ \spatstatAuthors. } \seealso{ \code{\link{psp}}, \code{\link{infline}} \code{\link{midpoints.psp}}, \code{\link{lengths_psp}} \code{\link{angles.psp}}, \code{\link{endpoints.psp}}. } \examples{ X <- psp(runif(4), runif(4), runif(4), runif(4), window=owin()) Y <- extrapolate.psp(X) plot(X, col=3, lwd=4) plot(Y, lty=3) Y } \keyword{spatial} \keyword{math} spatstat.geom/man/unique.ppp.Rd0000644000176200001440000000274114611065351016217 0ustar liggesusers\name{unique.ppp} \alias{unique.ppp} \alias{unique.ppx} \title{Extract Unique Points from a Spatial Point Pattern} \description{ Removes any points that are identical to other points in a spatial point pattern. } \usage{ \method{unique}{ppp}(x, \dots, warn=FALSE) \method{unique}{ppx}(x, \dots, warn=FALSE) } \arguments{ \item{x}{ A spatial point pattern (object of class \code{"ppp"} or \code{"ppx"}). } \item{\dots}{ Arguments passed to \code{\link{duplicated.ppp}} or \code{\link{duplicated.data.frame}}. } \item{warn}{ Logical. If \code{TRUE}, issue a warning message if any duplicated points were found. } } \value{ Another point pattern object. } \details{ These are methods for the generic function \code{unique} for point pattern datasets (of class \code{"ppp"}, see \code{\link{ppp.object}}, or class \code{"ppx"}). This function removes duplicate points in \code{x}, and returns a point pattern. Two points in a point pattern are deemed to be identical if their \eqn{x,y} coordinates are the same, \emph{and} their marks are the same (if they carry marks). This is the default rule: see \code{\link{duplicated.ppp}} for other options. } \seealso{ \code{\link{ppp.object}}, \code{\link{duplicated.ppp}}, \code{\link{multiplicity.ppp}} } \examples{ X <- ppp(c(1,1,0.5), c(2,2,1), window=square(3)) unique(X) unique(X, rule="deldir") } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/intensity.ppx.Rd0000644000176200001440000000175014611065346016752 0ustar liggesusers\name{intensity.ppx} \alias{intensity.ppx} \title{Intensity of a Multidimensional Space-Time Point Pattern} \description{ Calculates the intensity of points in a multi-dimensional point pattern of class \code{"ppx"} or \code{"pp3"}. } \usage{ \method{intensity}{ppx}(X, \dots) } \arguments{ \item{X}{Point pattern of class \code{"ppx"} or \code{"pp3"}.} \item{\dots}{Ignored.} } \value{ A single number or a numeric vector. } \details{ This is a method for the generic function \code{\link{intensity}}. It computes the empirical intensity of a multi-dimensional point pattern (object of class \code{"ppx"} including \code{"pp3"}), i.e. the average density of points per unit volume. If the point pattern is multitype, the intensities of the different types are computed separately. } \author{ \adrian \rolf and \ege } \examples{ X <- osteo$pts[[1]] intensity(X) marks(X) <- factor(sample(letters[1:3], npoints(X), replace=TRUE)) intensity(X) } spatstat.geom/man/methods.ppx.Rd0000644000176200001440000000347114611065347016372 0ustar liggesusers\name{methods.ppx} \Rdversion{1.1} \alias{methods.ppx} %DoNotExport \alias{print.ppx} \alias{plot.ppx} \alias{unitname.ppx} \alias{unitname<-.ppx} \alias{scale.ppx} \title{ Methods for Multidimensional Space-Time Point Patterns } \description{ Methods for printing and plotting a general multidimensional space-time point pattern. } \usage{ \method{print}{ppx}(x, ...) \method{plot}{ppx}(x, ...) \method{unitname}{ppx}(x) \method{unitname}{ppx}(x) <- value \method{scale}{ppx}(x, center=TRUE, scale=TRUE) } \arguments{ \item{x}{ Multidimensional point pattern (object of class \code{"ppx"}). } \item{\dots}{ Additional arguments passed to plot methods. } \item{value}{ Name of the unit of length. See \code{\link{unitname}}. } \item{center,scale}{ Arguments passed to \code{\link[base]{scale.default}} to determine the rescaling. } } \details{ These are methods for the generic functions \code{\link{print}}, \code{\link{plot}}, \code{\link{unitname}}, \code{\link{unitname<-}} and \code{\link[base]{scale}} for the class \code{"ppx"} of multidimensional point patterns. The \code{print} method prints a description of the point pattern and its spatial domain. The \code{unitname} method extracts the name of the unit of length in which the point coordinates are expressed. The \code{unitname<-} method assigns the name of the unit of length. The \code{scale} method rescales each spatial coordinate of \code{x}. } \value{ For \code{print.ppx} and \code{plot.ppx} the value is \code{NULL}. For \code{unitname.ppx} the value is an object of class \code{"units"}. For \code{unitname<-.ppx} and \code{scale.ppx} the value is another object of class \code{"ppx"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{ppx}}, \code{\link{unitname}} } \keyword{spatial} spatstat.geom/man/mergeLevels.Rd0000644000176200001440000000376014611065347016374 0ustar liggesusers\name{mergeLevels} \alias{mergeLevels} \title{ Merge Levels of a Factor } \description{ Specified levels of the factor will be merged into a single level. } \usage{ mergeLevels(.f, \dots) } \arguments{ \item{.f}{ A factor (or a factor-valued pixel image or a point pattern with factor-valued marks). } \item{\dots}{ List of \code{name=value} pairs, where \code{name} is the new merged level, and \code{value} is the vector of old levels that will be merged. } } \details{ This utility function takes a factor \code{.f} and merges specified levels of the factor. The grouping is specified by the arguments \code{\dots} which must each be given in the form \code{new=old}, where \code{new} is the name for the new merged level, and \code{old} is a character vector containing the old levels that are to be merged. The result is a new factor (or factor-valued object), in which the levels listed in \code{old} have been replaced by a single level \code{new}. An argument of the form \code{name=character(0)} or \code{name=NULL} is interpreted to mean that all other levels of the old factor should be mapped to \code{name}. } \value{ Another factor of the same length as \code{.f} (or object of the same kind as \code{.f}). } \section{Tips for manipulating factor levels}{ To remove unused levels from a factor \code{f}, just type \code{f <- factor(f)}. To change the ordering of levels in a factor, use \code{\link[base]{factor}(f, levels=l)} or \code{\link[stats]{relevel}(f, ref)}. } \seealso{ \code{\link[base]{factor}}, \code{\link[stats]{relevel}} } \author{ \adrian \rolf and \ege } \examples{ likert <- c("Strongly Agree", "Agree", "Neutral", "Disagree", "Strongly Disagree") answers <- factor(sample(likert, 15, replace=TRUE), levels=likert) answers mergeLevels(answers, Positive=c("Strongly Agree", "Agree"), Negative=c("Strongly Disagree", "Disagree")) } \keyword{manip} \keyword{spatial} spatstat.geom/man/plot.layered.Rd0000644000176200001440000000703614611065347016524 0ustar liggesusers\name{plot.layered} \alias{plot.layered} \title{ Layered Plot } \description{ Generates a layered plot. The plot method for objects of class \code{"layered"}. } \usage{ \method{plot}{layered}(x, ..., which = NULL, plotargs = NULL, add=FALSE, show.all=!add, main=NULL, do.plot=TRUE) } \arguments{ \item{x}{ An object of class \code{"layered"} created by the function \code{\link{layered}}. } \item{\dots}{ Arguments to be passed to the \code{plot} method for \emph{every} layer. } \item{which}{ Subset index specifying which layers should be plotted. } \item{plotargs}{ Arguments to be passed to the \code{plot} methods for individual layers. A list of lists of arguments of the form \code{name=value}. } \item{add}{Logical value indicating whether to add the graphics to an existing plot. } \item{show.all}{ Logical value indicating whether the \emph{first} layer should be displayed in full (including the main title, bounding window, coordinate axes, colour ribbon, and so on). } \item{main}{Main title for the plot} \item{do.plot}{Logical value indicating whether to actually do the plotting.} } \details{ Layering is a simple mechanism for controlling a high-level plot that is composed of several successive plots, for example, a background and a foreground plot. The layering mechanism makes it easier to plot, to switch on or off the plotting of each individual layer, to control the plotting arguments that are passed to each layer, and to zoom in on a subregion. The layers of data to be plotted should first be converted into a single object of class \code{"layered"} using the function \code{\link{layered}}. Then the layers can be plotted using the method \code{plot.layered}. To zoom in on a subregion, apply the subset operator \code{\link{[.layered}} to \code{x} before plotting. Graphics parameters for each layer are determined by (in order of precedence) \code{\dots}, \code{plotargs}, and \code{\link{layerplotargs}(x)}. The graphics parameters may also include the special argument \code{.plot} specifying (the name of) a function which will be used to perform the plotting instead of the generic \code{plot}. The argument \code{show.all} is recognised by many plot methods in \pkg{spatstat}. It determines whether a plot is drawn with all its additional components such as the main title, bounding window, coordinate axes, colour ribbons and legends. The default is \code{TRUE} for new plots and \code{FALSE} for added plots. In \code{plot.layered}, the argument \code{show.all} applies only to the \bold{first} layer. The subsequent layers are plotted with \code{show.all=FALSE}. To override this, that is, if you really want to draw all the components of \bold{all} layers of \code{x}, insert the argument \code{show.all=TRUE} in each entry of \code{plotargs} or \code{\link{layerplotargs}(x)}. } \value{ (Invisibly) a list containing the return values from the plot commands for each layer. This list has an attribute \code{"bbox"} giving a bounding box for the entire plot. } \author{\adrian and \rolf } \seealso{ \code{\link{layered}}, \code{\link{layerplotargs}}, \code{\link{[.layered}}, \code{\link{plot}}. } \examples{ D <- distmap(cells) L <- layered(D, cells) plot(L) plot(L, which = 2) plot(L, plotargs=list(list(ribbon=FALSE), list(pch=3, cols="white"))) # plot a subregion plot(L[, square(0.5)]) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/as.rectangle.Rd0000644000176200001440000000330414611065345016460 0ustar liggesusers\name{as.rectangle} \alias{as.rectangle} \title{Window Frame} \description{ Extract the window frame of a window or other spatial dataset } \usage{ as.rectangle(w, \dots) } \arguments{ \item{w}{A window, or a dataset that has a window. Either a window (object of class \code{"owin"}), a pixel image (object of class \code{"im"}) or other data determining such a window. } \item{\dots}{ Optional. Auxiliary data to help determine the window. If \code{w} does not belong to a recognised class, the arguments \code{w} and \code{\dots} are passed to \code{\link{as.owin}} to determine the window. } } \value{ A window (object of class \code{"owin"}) of type \code{"rectangle"} representing a rectangle. } \details{ This function is the quickest way to determine a bounding rectangle for a spatial dataset. If \code{w} is a window, the function just extracts the outer bounding rectangle of \code{w} as given by its elements \code{xrange,yrange}. The function can also be applied to any spatial dataset that has a window: for example, a point pattern (object of class \code{"ppp"}) or a line segment pattern (object of class \code{"psp"}). The bounding rectangle of the window of the dataset is extracted. Use the function \code{\link{boundingbox}} to compute the \emph{smallest} bounding rectangle of a dataset. } \seealso{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{boundingbox}} } \examples{ w <- owin(c(0,10),c(0,10), poly=list(x=c(1,2,3,2,1), y=c(2,3,4,6,7))) r <- as.rectangle(w) # returns a 10 x 10 rectangle as.rectangle(lansing) as.rectangle(copper$SouthLines) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/subset.psp.Rd0000644000176200001440000000727014611065350016222 0ustar liggesusers\name{subset.psp} \alias{subset.psp} \title{ Subset of Line Segment Satisfying A Condition } \description{ Given a line segment pattern, return the subset of segments which satisfy a specified condition. } \usage{ \method{subset}{psp}(x, subset, select, drop=FALSE, \dots) } \arguments{ \item{x}{ A line segment pattern (object of class \code{"psp"}). } \item{subset}{ Logical expression indicating which points are to be kept. The expression may involve the names of spatial coordinates of the segment endpoints (\code{x0}, \code{y0}, \code{x1}, \code{y1}), the \code{marks}, and (if there is more than one column of marks) the names of individual columns of marks. Missing values are taken as false. See Details. } \item{select}{ Expression indicating which columns of marks should be kept. The \emph{names} of columns of marks can be used in this expression, and will be treated as if they were column indices. See Details. } \item{drop}{ Logical value indicating whether to remove unused levels of the marks, if the marks are a factor. } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link{subset}}. It extracts the subset of \code{x} consisting of those segments that satisfy the logical expression \code{subset}, and retains only the columns of marks that are specified by the expression \code{select}. The result is always a line segment pattern, with the same window as \code{x}. The argument \code{subset} determines the subset that will be extracted. It should be a logical expression. It may involve the variable names \code{x0}, \code{y0}, \code{x1}, \code{y1} representing the Cartesian coordinates of the segment endpoints; the name \code{marks} representing the marks; and (if there is more than one column of marks) the names of individual columns of marks. The default is to keep all segments. The argument \code{select} determines which columns of marks will be retained (if there are several columns of marks). It should be an expression involving the names of columns of marks (which will be interpreted as integers representing the positions of these columns). For example if there are columns of marks named \code{A} to \code{Z}, then \code{select=D:F} is a valid expression and means that columns \code{D}, \code{E} and \code{F} will be retained. Similarly \code{select=-(A:C)} is valid and means that columns \code{A} to \code{C} will be deleted. The default is to retain all columns. Setting \code{subset=FALSE} will produce an empty point pattern (i.e. containing zero points) in the same window as \code{x}. Setting \code{select=FALSE} or \code{select= -marks} will remove all the marks from \code{x}. The argument \code{drop} determines whether to remove unused levels of a factor, if the resulting point pattern is multitype (i.e. the marks are a factor) or if the marks are a data frame in which some of the columns are factors. The result is always a line segment pattern. To extract only some columns of marks as a data frame, use \code{subset(as.data.frame(x), ...)} } \value{ A line segment pattern (object of class \code{"psp"}) in the same spatial window as \code{x}. The result is a subset of \code{x}, possibly with some columns of marks removed. } \author{ \spatstatAuthors. } \seealso{ \code{\link[base]{subset}}, \code{\link{[.psp}}. } \examples{ plot(nbw.seg) plot(subset(nbw.seg, x0 < 500 & y0 < 800), add=TRUE, lwd=6) subset(nbw.seg, type == "island") subset(nbw.seg, type == "coast", select= -type) subset(nbw.seg, type \%in\% c("island", "coast"), select= FALSE) } \keyword{spatial} \keyword{manip} spatstat.geom/man/rotate.Rd0000644000176200001440000000147214611065350015410 0ustar liggesusers\name{rotate} \alias{rotate} \title{Rotate} \description{ Applies a rotation to any two-dimensional object, such as a point pattern or a window. } \usage{ rotate(X, \dots) } \arguments{ \item{X}{Any suitable dataset representing a two-dimensional object, such as a point pattern (object of class \code{"ppp"}), or a window (object of class \code{"owin"}).} \item{\dots}{Data specifying the rotation.} } \value{ Another object of the same type, representing the result of rotating \code{X} through the specified angle. } \details{ This is generic. Methods are provided for point patterns (\code{\link{rotate.ppp}}) and windows (\code{\link{rotate.owin}}). } \seealso{ \code{\link{rotate.ppp}}, \code{\link{rotate.owin}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/sessionLibs.Rd0000644000176200001440000000153414611065350016406 0ustar liggesusers\name{sessionLibs} \alias{sessionLibs} \title{ Print Names and Version Numbers of Libraries Loaded } \description{ Prints the names and version numbers of libraries currently loaded by the user. } \usage{ sessionLibs() } \details{ This function prints a list of the libraries loaded by the user in the current session, giving just their name and version number. It obtains this information from \code{\link[utils]{sessionInfo}}. This function is not needed in an interactive \R session because the package startup messages will usually provide this information. Its main use is in an \code{\link{Sweave}} script, where it is needed because the package startup messages are not printed. } \value{ Null. } \examples{ sessionLibs() } \author{ \adrian and \rolf. } \seealso{ \code{\link[utils]{sessionInfo}} } \keyword{data} spatstat.geom/man/identify.psp.Rd0000644000176200001440000000351414611065346016532 0ustar liggesusers\name{identify.psp} \alias{identify.psp} \title{Identify Segments in a Line Segment Pattern} \description{ If a line segment pattern is plotted in the graphics window, this function will find the segment which is nearest to the mouse position, and print its serial number. } \usage{ \method{identify}{psp}(x, \dots, labels=seq_len(nsegments(x)), n=nsegments(x), plot=TRUE) } \arguments{ \item{x}{ A line segment pattern (object of class \code{"psp"}). } \item{labels}{ Labels associated with the segments, to be plotted when the segments are identified. A character vector or numeric vector of length equal to the number of segments in \code{x}. } \item{n}{ Maximum number of segments to be identified. } \item{plot}{ Logical. Whether to plot the labels when a segment is identified. } \item{\dots}{ Arguments passed to \code{\link[graphics]{text.default}} controlling the plotting of the labels. } } \value{ Vector containing the serial numbers of the segments in the pattern \code{x} that were identified. } \details{ This is a method for the generic function \code{\link[graphics]{identify}} for line segment pattern objects. The line segment pattern \code{x} should first be plotted using \code{\link{plot.psp}}. Then \code{identify(x)} reads the position of the graphics pointer each time the left mouse button is pressed. It then finds the segment in the pattern \code{x} that is closest to the mouse position. This segment's index will be returned as part of the value of the call. Each time a segment is identified, text will be displayed next to the point, showing its serial number (or the relevant entry of \code{labels}). } \seealso{ \code{\link[graphics]{identify}}, \code{\link{identify.ppp}}. } \author{ \spatstatAuthors } \keyword{spatial} \keyword{iplot} spatstat.geom/man/scanpp.Rd0000644000176200001440000000716514611065350015403 0ustar liggesusers\name{scanpp} \alias{scanpp} \title{Read Point Pattern From Data File} \description{ Reads a point pattern dataset from a text file. } \usage{ scanpp(filename, window, header=TRUE, dir="", factor.marks=NULL, ...) } \arguments{ \item{filename}{ String name of the file containing the coordinates of the points in the point pattern, and their marks if any. } \item{window}{ Window for the point pattern. An object of class \code{"owin"}. } \item{header}{ Logical flag indicating whether the first line of the file contains headings for the columns. Passed to \code{\link[utils]{read.table}}. } \item{dir}{ String containing the path name of the directory in which \code{filename} is to be found. Default is the current directory. } \item{factor.marks}{ Logical vector (or NULL) indicating whether marks are to be interpreted as factors. Defaults to \code{NULL} which means that strings will be interpreted as factors while numeric variables will not. See details. } \item{\dots}{ Ignored. } } \value{ A point pattern (an object of class \code{"ppp"}, see \code{\link{ppp.object}}). } \details{ This simple function reads a point pattern dataset from a file containing the cartesian coordinates of its points, and optionally the mark values for these points. The file identified by \code{filename} in directory \code{dir} should be a text file that can be read using \code{\link[utils]{read.table}}. Thus, each line of the file (except possibly the first line) contains data for one point in the point pattern. Data are arranged in columns. There should be either two columns (for an unmarked point pattern) or more columns (for a marked point pattern). If \code{header=FALSE} then the first two columns of data will be interpreted as the \eqn{x} and \eqn{y} coordinates of points. Remaining columns, if present, will be interpreted as containing the marks for these points. If \code{header=TRUE} then the first line of the file should contain string names for each of the columns of data. If there are columns named \code{x} and \code{y} then these will be taken as the cartesian coordinates, and any remaining columns will be taken as the marks. If there are no columns named \code{x} and \code{y} then the first and second columns will be taken as the cartesian coordinates. If a logical vector is provided for \code{factor.marks} the length should equal the number of mark columns (a shorter \code{factor.marks} is recycled to this length). This vector is then used to determine which mark columns should be interpreted as factors. Note: Strings will not be interpreted as factors if the corresponding entry in \code{factor.marks} is \code{FALSE}. Note that there is intentionally no default for \code{window}. The window of observation should be specified. If you really need to estimate the window, use the Ripley-Rasson estimator \code{\link{ripras}}. } \seealso{ \code{\link{ppp.object}}, \code{\link{ppp}}, \code{\link{as.ppp}}, \code{\link{ripras}} } \author{ \adrian and \rolf. } \examples{ ## files installed with spatstat, for demonstration d <- system.file("rawdata", "finpines", package="spatstat.data") if(nzchar(d)) { W <- owin(c(-5,5), c(-8,2)) X <- scanpp("finpines.txt", dir=d, window=W) print(X) } d <- system.file("rawdata", "amacrine", package="spatstat.data") if(nzchar(d)) { W <- owin(c(0, 1060/662), c(0, 1)) Y <- scanpp("amacrine.txt", dir=d, window=W, factor.marks=TRUE) print(Y) } } \keyword{spatial} \keyword{IO} spatstat.geom/man/tile.areas.Rd0000644000176200001440000000175414611065351016145 0ustar liggesusers\name{tile.areas} \alias{tile.areas} \title{Compute Areas of Tiles in a Tessellation} \description{ Computes the area of each tile in a tessellation. } \usage{ tile.areas(x) } \arguments{ \item{x}{A tessellation (object of class \code{"tess"}).} } \details{ A tessellation is a collection of disjoint spatial regions (called \emph{tiles}) that fit together to form a larger spatial region. See \code{\link{tess}}. This command computes the area of each of the tiles that make up the tessellation \code{x}. The result is a numeric vector in the same order as the tiles would be listed by \code{tiles(x)}. } \value{ A numeric vector. } \seealso{ \code{\link{tess}}, \code{\link{tiles}}, \code{\link{tilenames}}, \code{\link{tiles.empty}} } \examples{ A <- tess(xgrid=0:2,ygrid=0:2) tile.areas(A) v <- as.im(function(x,y){factor(round(x^2 + y^2))}, W=owin()) E <- tess(image=v) tile.areas(E) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/plot.tess.Rd0000644000176200001440000001242614611065347016054 0ustar liggesusers\name{plot.tess} \alias{plot.tess} \title{Plot a Tessellation} \description{ Plots a tessellation, with optional labels for the tiles, and optional filled colour in each tile. } \usage{ \method{plot}{tess}(x, \dots, main, add=FALSE, show.all=!add, border=NULL, do.plot=TRUE, do.labels=!missing(labels), labels=tilenames(x), labelargs=list(), do.col=!missing(values), values=marks(x), multiplot=TRUE, col=NULL, ribargs=list()) } \arguments{ \item{x}{Tessellation (object of class \code{"tess"}) to be plotted.} \item{\dots}{Arguments controlling the appearance of the plot.} \item{main}{Heading for the plot. A character string.} \item{add}{Logical. Determines whether the tessellation plot is added to the existing plot. } \item{show.all}{ Logical value indicating whether to plot everything including the main title and the observation window of \code{x}. } \item{border}{ Colour of the tile boundaries. A character string or other value specifying a single colour. Ignored for pixel tessellations. } \item{do.plot}{ Logical value indicating whether to actually perform the plot. } \item{do.labels}{ Logical value indicating whether to show a text label for each tile of the tessellation. The default is \code{TRUE} if \code{labels} are given, and \code{FALSE} otherwise. } \item{labels}{Character vector of labels for the tiles.} \item{labelargs}{ List of arguments passed to \code{\link{text.default}} to control display of the text labels. } \item{do.col}{ Logical value indicating whether tiles should be filled with colour (for tessellations where the tiles are rectangles or polygons). The default is \code{TRUE} if \code{values} are given, and \code{FALSE} otherwise. } \item{values}{ A vector of numerical values (or a factor, or vector of character strings) that will be associated with each tile of the tessellation and which determine the colour of the tile. The default is the marks of \code{x}. If the tessellation is not marked, or if the argument \code{values=NULL} is given, the default is a factor giving the tile identifier. } \item{multiplot}{ Logical value giving permission to display multiple plot panels. This applies when \code{do.col=TRUE} and \code{ncol(values) > 1}. } \item{col}{ A vector of colours for each of the \code{values}, or a \code{\link{colourmap}} that maps these values to colours. } \item{ribargs}{ List of additional arguments to control the plot of the colour map, if \code{do.col=TRUE}. See explanation in \code{\link{plot.im}}. } } \details{ This is a method for the generic \code{\link{plot}} function for the class \code{"tess"} of tessellations (see \code{\link{tess}}). The window of the tessellation is plotted, and then the tiles of the tessellation are plotted in their correct positions in the window. Rectangular or polygonal tiles are plotted individually using \code{\link{plot.owin}}, while a tessellation represented by a pixel image is plotted using \code{\link{plot.im}}. The arguments \code{\dots} control the appearance of the plot, and are passed to \code{\link{segments}}, \code{\link{plot.owin}} or \code{\link{plot.im}} as appropriate. If \code{do.col=TRUE}, then the tiles of the tessellation are filled with colours determined by the argument \code{values}. By default, these values are the marks associated with each of the tiles. If there is more than one column of marks or values, then the default behaviour (if \code{multiplot=TRUE}) is to display several plot panels, one for each column of mark values. Then the arguments \code{\dots} are passed to \code{\link{plot.solist}} to determine the arrangement of the panels. If \code{do.labels=TRUE}, a text label is plotted in the middle of each tile. The text labels are determined by the argument \code{labels}, and default to the names of the tiles given by \code{tilenames(x)}. } \value{ (Invisible) window of class \code{"owin"} specifying a bounding box for the plot, or an object of class \code{"colourmap"} specifying the colour map. (In the latter case, the bounding box information is available as an attribute, and can be extracted using \code{\link{as.owin}}.) } \seealso{ \code{\link{tess}} } \examples{ Rect <- tess(xgrid=0:4,ygrid=0:4) Diri <- dirichlet(runifrect(7)) plot(Diri) plot(Rect, border="blue", lwd=2, lty=2) plot(Rect, do.col=TRUE, border="white") plot(Rect, do.col=TRUE, values=runif(16), border="white") B <- Rect[c(1, 2, 5, 7, 9)] plot(B, hatch=TRUE) plot(Diri, do.col=TRUE) plot(Diri, do.col=TRUE, do.labels=TRUE, labelargs=list(col="white"), ribbon=FALSE) v <- as.im(function(x,y){factor(round(5 * (x^2 + y^2)))}, W=owin()) levels(v) <- letters[seq(length(levels(v)))] Img <- tess(image=v) plot(Img) plot(Img, col=rainbow(11), ribargs=list(las=1)) a <- tile.areas(Diri) marks(Diri) <- data.frame(area=a, random=runif(7, max=max(a))) plot(Diri, do.col=TRUE, equal.ribbon=TRUE) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} \concept{Tessellation} spatstat.geom/man/test.crossing.psp.Rd0000644000176200001440000000255514611065351017524 0ustar liggesusers\name{test.crossing.psp} \alias{test.crossing.psp} \alias{test.selfcrossing.psp} \title{ Check Whether Segments Cross } \description{ Determine whether there is a crossing (intersection) between each pair of line segments. } \usage{ test.crossing.psp(A, B) test.selfcrossing.psp(A) } \arguments{ \item{A,B}{ Line segment patterns (objects of class \code{"psp"}). } } \details{ These functions decide whether the given line segments intersect each other. If \code{A} and \code{B} are two spatial patterns of line segments, \code{test.crossing.psp(A, B)} returns a logical matrix in which the entry on row \code{i}, column \code{j} is equal to \code{TRUE} if segment \code{A[i]} has an intersection with segment \code{B[j]}. If \code{A} is a pattern of line segments, \code{test.selfcross.psp(A)} returns a symmetric logical matrix in which the entry on row \code{i}, column \code{j} is equal to \code{TRUE} if segment \code{A[i]} has an intersection with segment \code{A[j]}. } \value{ A logical matrix. } \author{ \spatstatAuthors. } \seealso{ \code{\link{psp}} } \examples{ B <- edges(letterR) if(require(spatstat.random)) { A <- rpoisline(5, Frame(B)) } else { FB <- Frame(B) A <- as.psp(from=runifrect(5, FB), to=runifrect(5, FB)) } MA <- test.selfcrossing.psp(A) MAB <- test.crossing.psp(A, B) } \keyword{spatial} \keyword{math} spatstat.geom/man/incircle.Rd0000644000176200001440000000240014611065346015677 0ustar liggesusers\name{incircle} \alias{incircle} \alias{inradius} \title{Find Largest Circle Inside Window} \description{ Find the largest circle contained in a given window. } \usage{ incircle(W) inradius(W) } \arguments{ \item{W}{A window (object of class \code{"owin"}).} } \details{ Given a window \code{W} of any type and shape, the function \code{incircle} determines the largest circle that is contained inside \code{W}, while \code{inradius} computes its radius only. For non-rectangular windows, the incircle is computed approximately by finding the maximum of the distance map (see \code{\link{distmap}}) of the complement of the window. } \value{ The result of \code{incircle} is a list with entries \code{x,y,r} giving the location \code{(x,y)} and radius \code{r} of the incircle. The result of \code{inradius} is the numerical value of radius. } \seealso{ \code{\link{centroid.owin}} } \examples{ W <- square(1) Wc <- incircle(W) plot(W) plot(disc(Wc$r, c(Wc$x, Wc$y)), add=TRUE) plot(letterR) Rc <- incircle(letterR) plot(disc(Rc$r, c(Rc$x, Rc$y)), add=TRUE) W <- as.mask(letterR) plot(W) Rc <- incircle(W) plot(disc(Rc$r, c(Rc$x, Rc$y)), add=TRUE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/ripras.Rd0000644000176200001440000000612614611065350015413 0ustar liggesusers\name{ripras} \alias{ripras} \title{Estimate window from points alone} \description{ Given an observed pattern of points, computes the Ripley-Rasson estimate of the spatial domain from which they came. } \usage{ ripras(x, y=NULL, shape="convex", f) } \arguments{ \item{x}{ vector of \code{x} coordinates of observed points, or a 2-column matrix giving \code{x,y} coordinates, or a list with components \code{x,y} giving coordinates (such as a point pattern object of class \code{"ppp"}.) } \item{y}{(optional) vector of \code{y} coordinates of observed points, if \code{x} is a vector.} \item{shape}{String indicating the type of window to be estimated: either \code{"convex"} or \code{"rectangle"}. } \item{f}{ (optional) scaling factor. See Details. } } \value{ A window (an object of class \code{"owin"}). } \details{ Given an observed pattern of points with coordinates given by \code{x} and \code{y}, this function computes an estimate due to Ripley and Rasson (1977) of the spatial domain from which the points came. The points are assumed to have been generated independently and uniformly distributed inside an unknown domain \eqn{D}. If \code{shape="convex"} (the default), the domain \eqn{D} is assumed to be a convex set. The maximum likelihood estimate of \eqn{D} is the convex hull of the points (computed by \code{\link{convexhull.xy}}). Analogously to the problems of estimating the endpoint of a uniform distribution, the MLE is not optimal. Ripley and Rasson's estimator is a rescaled copy of the convex hull, centred at the centroid of the convex hull. The scaling factor is \eqn{1/sqrt(1 - m/n)}{1/\sqrt{1 - \frac m n}} where \eqn{n} is the number of data points and \eqn{m} the number of vertices of the convex hull. The scaling factor may be overridden using the argument \code{f}. If \code{shape="rectangle"}, the domain \eqn{D} is assumed to be a rectangle with sides parallel to the coordinate axes. The maximum likelihood estimate of \eqn{D} is the bounding box of the points (computed by \code{\link{bounding.box.xy}}). The Ripley-Rasson estimator is a rescaled copy of the bounding box, with scaling factor \eqn{(n+1)/(n-1)} where \eqn{n} is the number of data points, centred at the centroid of the bounding box. The scaling factor may be overridden using the argument \code{f}. } \seealso{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{bounding.box.xy}}, \code{\link{convexhull.xy}} } \examples{ x <- runif(30) y <- runif(30) w <- ripras(x,y) plot(owin(), main="ripras(x,y)") plot(w, add=TRUE) points(x,y) X <- runifrect(15) plot(X, main="ripras(X)") plot(ripras(X), add=TRUE) # two points insufficient ripras(c(0,1),c(0,0)) # triangle ripras(c(0,1,0.5), c(0,0,1)) # three collinear points ripras(c(0,0,0), c(0,1,2)) } \references{ Ripley, B.D. and Rasson, J.-P. (1977) Finding the edge of a Poisson forest. \emph{Journal of Applied Probability}, \bold{14}, 483 -- 491. } \author{\adrian and \rolf } \keyword{spatial} \keyword{utilities} spatstat.geom/man/plot.psp.Rd0000644000176200001440000001740714611065347015704 0ustar liggesusers\name{plot.psp} \alias{plot.psp} \title{plot a Spatial Line Segment Pattern} \description{ Plot a two-dimensional line segment pattern } \usage{ \method{plot}{psp}(x, \dots, main, add=FALSE, show.all=!add, show.window=show.all, do.plot=TRUE, use.marks=TRUE, which.marks=1, style=c("colour", "width", "none"), col=NULL, ribbon=show.all, ribsep=0.15, ribwid=0.05, ribn=1024, scale=NULL, adjust=1, legend=TRUE, leg.side=c("right", "left", "bottom", "top"), leg.sep=0.1, leg.wid=0.1, leg.args=list(), leg.scale=1, negative.args=list(col=2)) } \arguments{ \item{x}{ The line segment pattern to be plotted. An object of class \code{"psp"}, or data which can be converted into this format by \code{\link{as.psp}()}. } \item{\dots}{ extra arguments that will be passed to the plotting functions \code{\link{segments}} (to plot the segments) and \code{\link{plot.owin}} (to plot the observation window). } \item{main}{ Character string giving a title for the plot. } \item{add}{ Logical. If \code{TRUE}, the current plot is not erased; the segments are plotted on top of the current plot, and the window is not plotted (by default). } \item{show.all}{ Logical value specifying whether to plot everything including the window, main title, and colour ribbon. } \item{show.window}{ Logical value specifying whether to plot the window. } \item{do.plot}{ Logical value indicating whether to actually perform the plot. } \item{use.marks}{ Logical value specifying whether to use the marks attached to the segments (\code{use.marks=TRUE}, the default) or to ignore them (\code{use.marks=FALSE}). } \item{which.marks}{ Index determining which column of marks to use, if the marks of \code{x} are a data frame. A character string or an integer. Defaults to \code{1} indicating the first column of marks. } \item{style}{ Character string specifying how to represent the mark value of each segment. If \code{style="colour"} (the default) segments are coloured according to their mark value. If \code{style="width"}, segments are drawn with a width proportional to their mark value. If \code{style="none"} the mark values are ignored. } \item{col}{ Colour information. If \code{style="width"} or \code{style="none"}, then \code{col} should be a single value, interpretable as a colour; the line segments will be plotted using this colour. If \code{style="colour"} and \code{x} has marks, then the mark values will be mapped to colours using the information in \code{col}, which should be a colour map (object of class \code{"colourmap"}) or a vector of colour values. } \item{ribbon}{ Logical value indicating whether to display a ribbon showing the colour map (in which mark values are associated with colours) when \code{style="colour"}. } \item{ribsep}{ Factor controlling the space between the colour ribbon and the image. } \item{ribwid}{ Factor controlling the width of the colour ribbon. } \item{ribn}{ Number of different values to display in the colour ribbon. } \item{scale}{ Optional. Physical scale for representing the mark values of \code{x} as physical widths on the plot, when \code{style="width"}. There is a sensible default. } \item{adjust}{ Optional adjustment factor for \code{scale}. } \item{legend}{ Logical value indicating whether to display a legend showing the width map (in which mark values are associated with segment widths) when \code{style="width"}. } \item{leg.side}{ Character string (partially matched) specifying where the legend should be plotted, when \code{style="width"}. } \item{leg.sep}{ Factor controlling the space between the legend and the main plot, when \code{style="width"}. } \item{leg.wid}{ Factor controlling the width of the legend, when \code{style="width"}. } \item{leg.args}{ Optional list of additional arguments passed to \code{\link[graphics]{axis}} and \code{\link[graphics]{text.default}} controlling the appearance of the legend, when \code{style="width"}. } \item{leg.scale}{ Rescaling factor for labels, when \code{style="width"}. The values on the numerical scale printed beside the legend will be multiplied by this rescaling factor. } \item{negative.args}{ Optional list of arguments to \code{\link[graphics]{polygon}} to be used when the mark values are negative. } } \value{ If \code{style="colour"}, the result is a \code{\link{colourmap}} object specifying the association between marks and colours, if any. If \code{style="width"}, the result is a numeric value giving the scaling between the mark values and the physical widths. In all cases, the return value also has an attribute \code{"bbox"} giving a bounding box for the plot. } \details{ This is the \code{plot} method for line segment pattern datasets (of class \code{"psp"}, see \code{\link{psp.object}}). It plots both the observation window \code{Window(x)} and the line segments themselves. Plotting of the window \code{Window(x)} is performed by \code{\link{plot.owin}}. This plot may be modified through the \code{...} arguments. Plotting of the segments themselves is performed by the standard R function \code{\link{segments}}. Its plotting behaviour may also be modified through the \code{...} arguments. There are three different styles of plotting which apply when the segments have marks (i.e. when \code{marks(x)} is not null): \describe{ \item{\code{style="colour"} (the default):}{ Segments are plotted with different colours depending on their mark values. The colour map, associating mark values with colours, is determined by the argument \code{col}. The colour map will be displayed as a vertical colour ribbon to the right of the plot, if \code{ribbon=TRUE} (the default). } \item{\code{style="width"}:}{ Segments are plotted with different widths depending on their mark values. The expanded segments are plotted using the base graphics function \code{\link[graphics]{polygon}}. The width map, associating mark values with line widths, can be specified by giving the physical scale factor \code{scale}. There is a sensible default scale, which can be adjusted using the adjustment factor \code{adjust}. The width map will be displayed as a vertical stack of lines to the right of the plot, if \code{legend=TRUE} (the default). } \item{\code{style="none"} or \code{use.marks=FALSE}:}{ Mark information is ignored and the segments are plotted as thin lines using \code{\link[graphics]{segments}}. } } If \code{marks(x)} is a data frame, the default is to use the first column of \code{marks(x)} to determine the colours or widths. To specify another column, use the argument \code{which.marks}. } \seealso{ \code{\link{psp.object}}, \code{\link{plot}}, \code{\link{par}}, \code{\link{plot.owin}}, \code{\link{text.psp}}, \code{\link{symbols}} } \examples{ X <- psp(runif(20), runif(20), runif(20), runif(20), window=owin()) plot(X) plot(X, lwd=3) lettuce <- sample(letters[1:4], 20, replace=TRUE) marks(X) <- data.frame(A=1:20, B=factor(lettuce)) plot(X) plot(X, which.marks="B") plot(X, style="width", col="grey") } \author{ \adrian and \rolf } \keyword{spatial} \keyword{hplot} spatstat.geom/man/edges.Rd0000644000176200001440000000202214611065346015176 0ustar liggesusers\name{edges} \alias{edges} \title{ Extract Boundary Edges of a Window. } \description{ Extracts the boundary edges of a window and returns them as a line segment pattern. } \usage{ edges(x, \dots, window = NULL, check = FALSE) } \arguments{ \item{x}{ A window (object of class \code{"owin"}), or data acceptable to \code{\link{as.owin}}, specifying the window whose boundary is to be extracted. } \item{\dots}{ Ignored. } \item{window}{ Window to contain the resulting line segments. Defaults to \code{as.rectangle(x)}. } \item{check}{ Logical. Whether to check the validity of the resulting segment pattern. } } \details{ The boundary edges of the window \code{x} will be extracted as a line segment pattern. } \value{ A line segment pattern (object of class \code{"psp"}). } \seealso{ \code{\link{perimeter}} for calculating the total length of the boundary. } \examples{ edges(square(1)) edges(letterR) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/coords.Rd0000644000176200001440000000506114611065345015405 0ustar liggesusers\name{coords} \Rdversion{1.1} \alias{coords} \alias{coords.ppp} \alias{coords.ppx} \alias{coords.quad} \alias{coords<-} \alias{coords<-.ppp} \alias{coords<-.ppx} \title{ Extract or Change Coordinates of a Spatial or Spatiotemporal Point Pattern } \description{ Given any kind of spatial or space-time point pattern, this function extracts the (space and/or time and/or local) coordinates of the points and returns them as a data frame. } \usage{ coords(x, ...) \method{coords}{ppp}(x, ...) \method{coords}{ppx}(x, ..., spatial = TRUE, temporal = TRUE, local=TRUE) coords(x, ...) <- value \method{coords}{ppp}(x, ...) <- value \method{coords}{ppx}(x, ..., spatial = TRUE, temporal = TRUE, local=TRUE) <- value \method{coords}{quad}(x, ...) } \arguments{ \item{x}{ A point pattern: either a two-dimensional point pattern (object of class \code{"ppp"}), a three-dimensional point pattern (object of class \code{"pp3"}), or a general multidimensional space-time point pattern (object of class \code{"ppx"}) or a quadrature scheme (object of class \code{"quad"}). } \item{\dots}{ Further arguments passed to methods. } \item{spatial,temporal,local}{ Logical values indicating whether to extract spatial, temporal and local coordinates, respectively. The default is to return all such coordinates. (Only relevant to \code{ppx} objects). } \item{value}{ New values of the coordinates. A numeric vector with one entry for each point in \code{x}, or a numeric matrix or data frame with one row for each point in \code{x}. } } \details{ The function \code{coords} extracts the coordinates from a point pattern. The function \code{coords<-} replaces the coordinates of the point pattern with new values. Both functions \code{coords} and \code{coords<-} are generic, with methods for the classes \code{"ppp"}) and \code{"ppx"}. An object of class \code{"pp3"} also inherits from \code{"ppx"} and is handled by the method for \code{"ppx"}. } \value{ \code{coords} returns a \code{data.frame} with one row for each point, containing the coordinates. \code{coords<-} returns the altered point pattern. } \author{\adrian and \rolf } \seealso{ \code{\link{ppx}}, \code{\link{pp3}}, \code{\link{ppp}}, \code{as.hyperframe.ppx}, \code{as.data.frame.ppx}. } \examples{ df <- data.frame(x=runif(4),y=runif(4),t=runif(4)) X <- ppx(data=df, coord.type=c("s","s","t")) coords(X) coords(X, temporal=FALSE) coords(X) <- matrix(runif(12), ncol=3) } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.data.frame.owin.Rd0000644000176200001440000000411314611065345017470 0ustar liggesusers\name{as.data.frame.owin} \alias{as.data.frame.owin} \title{Convert Window to Data Frame} \description{ Converts a window object to a data frame. } \usage{ \method{as.data.frame}{owin}(x, \dots, drop=TRUE) } \arguments{ \item{x}{ Window (object of class \code{"owin"}). } \item{\dots}{Further arguments passed to \code{\link[base:as.data.frame]{as.data.frame.default}} to determine the row names and other features. } \item{drop}{ Logical value indicating whether to discard pixels that are outside the window, when \code{x} is a binary mask. } } \details{ This function returns a data frame specifying the coordinates of the window. If \code{x} is a binary mask window, the result is a data frame with columns \code{x} and \code{y} containing the spatial coordinates of each \emph{pixel}. If \code{drop=TRUE} (the default), only pixels inside the window are retained. If \code{drop=FALSE}, all pixels are retained, and the data frame has an extra column \code{inside} containing the logical value of each pixel (\code{TRUE} for pixels inside the window, \code{FALSE} for outside). If \code{x} is a rectangle or a polygonal window, the result is a data frame with columns \code{x} and \code{y} containing the spatial coordinates of the \emph{vertices} of the window. If the boundary consists of several polygons, the data frame has additional columns \code{id}, identifying which polygon is being traced, and \code{sign}, indicating whether the polygon is an outer or inner boundary (\code{sign=1} and \code{sign=-1} respectively). } \value{ A data frame with columns named \code{x} and \code{y}, and possibly other columns. } \author{ \spatstatAuthors. } \seealso{ \code{\link{as.data.frame.im}}, \code{\link{as.owin.data.frame}} } \examples{ as.data.frame(square(1)) holey <- owin(poly=list( list(x=c(0,10,0), y=c(0,0,10)), list(x=c(2,2,4,4), y=c(2,4,4,2)))) as.data.frame(holey) M <- as.mask(holey, eps=0.5) Mdf <- as.data.frame(M) } \keyword{spatial} \keyword{methods} spatstat.geom/man/contour.im.Rd0000644000176200001440000001013214611065345016204 0ustar liggesusers\name{contour.im} \alias{contour.im} \title{Contour plot of pixel image} \description{ Generates a contour plot of a pixel image. } \usage{ \method{contour}{im}(x, \dots, main, axes=FALSE, add=FALSE, nlevels=10, levels=NULL, labels=NULL, log=FALSE, col=par("fg"), clipwin=NULL, show.all=!add, do.plot=TRUE) } \arguments{ \item{x}{ Pixel image to be plotted. An object of class \code{"im"}. } \item{main}{ Character string to be displayed as the main title. } \item{nlevels,levels}{ Arguments passed to \code{\link[graphics]{contour.default}} controlling the choice of contour levels. } \item{labels}{ Arguments passed to \code{\link[graphics]{contour.default}} controlling the text labels plotted next to the contour lines. } \item{log}{ Logical value. If \code{TRUE}, the contour levels will be evenly-spaced on a logarithmic scale. } \item{axes}{ Logical. If \code{TRUE}, coordinate axes are plotted (with tick marks) around a region slightly larger than the image window. If \code{FALSE} (the default), no axes are plotted, and a box is drawn tightly around the image window. Ignored if \code{add=TRUE}. } \item{add}{ Logical. If \code{FALSE}, a new plot is created. If \code{TRUE}, the contours are drawn over the existing plot. } \item{col}{ Colour in which to draw the contour lines. Either a single value that can be interpreted as a colour value, or a \code{colourmap} object. } \item{clipwin}{ Optional. A window (object of class \code{"owin"}). Only this subset of the data will be displayed. } \item{\dots}{ Other arguments passed to \code{\link{contour.default}} controlling the contour plot; see Details. } \item{show.all}{ Logical value indicating whether to display all plot elements including the main title, bounding box, and (if \code{axis=TRUE}) coordinate axis markings. Default is \code{TRUE} for new plots and \code{FALSE} for added plots. } \item{do.plot}{ Logical value indicating whether to actually perform the plot. } } \details{ This is a method for the generic \code{contour} function, for objects of the class \code{"im"}. An object of class \code{"im"} represents a pixel image; see \code{\link{im.object}}. This function displays the values of the pixel image \code{x} as a contour plot on the current plot device, using equal scales on the \eqn{x} and \eqn{y} axes. The appearance of the plot can be modified using any of the arguments listed in the help for \code{\link{contour.default}}. Useful ones include: \describe{ \item{nlevels}{ Number of contour levels to plot. } \item{drawlabels}{ Whether to label the contour lines with text. } \item{col,lty,lwd}{ Colour, type, and width of contour lines. } } See \code{\link{contour.default}} for a full list of these arguments. The defaults for any of the abovementioned arguments can be reset using \code{\link{spatstat.options}("par.contour")}. If \code{log=TRUE}, the contour lines will be evenly-spaced on a logarithmic scale, provided the range of pixel values is at least 1.5 orders of magnitude (a ratio of at least 32). Otherwise the levels will be evenly-spaced on the original scale. If \code{col} is a colour map (object of class \code{"colourmap"}, see \code{\link{colourmap}}) then the contours will be plotted in different colours as determined by the colour map. The contour at level \code{z} will be plotted in the colour \code{col(z)} associated with this level in the colour map. } \value{ Invisibly, a rectangle (object of class \code{"owin"} specifying a rectangle) containing the plotted region. } \examples{ # an image Z <- setcov(owin()) contour(Z, axes=TRUE) contour(Z) V <- 100 * Z^2 + 1 contour(V, log=TRUE, labcex=1) co <- colourmap(rainbow(100), range=c(0,1)) contour(Z, col=co, lwd=2) } \seealso{ \code{\link{im.object}}, \code{\link{plot.im}}, \code{\link{persp.im}} } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/as.ppp.Rd0000644000176200001440000001165414611065345015322 0ustar liggesusers\name{as.ppp} \alias{as.ppp} \alias{as.ppp.ppp} \alias{as.ppp.psp} \alias{as.ppp.quad} \alias{as.ppp.matrix} \alias{as.ppp.data.frame} \alias{as.ppp.default} \title{Convert Data To Class ppp} \description{ Tries to coerce any reasonable kind of data to a spatial point pattern (an object of class \code{"ppp"}) for use by the \pkg{spatstat} package). } \usage{ as.ppp(X, \dots, fatal=TRUE) \method{as.ppp}{ppp}(X, \dots, fatal=TRUE) \method{as.ppp}{psp}(X, \dots, fatal=TRUE) \method{as.ppp}{quad}(X, \dots, fatal=TRUE) \method{as.ppp}{matrix}(X, W=NULL, \dots, fatal=TRUE) \method{as.ppp}{data.frame}(X, W=NULL, \dots, fatal=TRUE) \method{as.ppp}{default}(X, W=NULL, \dots, fatal=TRUE) } \arguments{ \item{X}{Data which will be converted into a point pattern} \item{W}{ Data which define a window for the pattern, when \code{X} does not contain a window. (Ignored if \code{X} contains window information.) } \item{\dots}{Ignored.} \item{fatal}{ Logical value specifying what to do if the data cannot be converted. See Details. } } \value{ An object of class \code{"ppp"} (see \code{\link{ppp.object}}) describing the point pattern and its window of observation. The value \code{NULL} may also be returned; see Details. } \details{ Converts the dataset \code{X} to a point pattern (an object of class \code{"ppp"}; see \code{\link{ppp.object}} for an overview). This function is normally used to convert an existing point pattern dataset, stored in another format, to the \code{"ppp"} format. To create a new point pattern from raw data such as \eqn{x,y} coordinates, it is normally easier to use the creator function \code{\link{ppp}}. The function \code{as.ppp} is generic, with methods for the classes \code{"ppp"}, \code{"psp"}, \code{"quad"}, \code{"matrix"}, \code{"data.frame"} and a default method. The dataset \code{X} may be: \itemize{ \item an object of class \code{"ppp"} \item an object of class \code{"psp"} \item a point pattern object created by the \pkg{spatial} library \item an object of class \code{"quad"} representing a quadrature scheme (see \code{\link{quad.object}}) \item a matrix or data frame with at least two columns \item a structure with entries \code{x}, \code{y} which are numeric vectors of equal length \item a numeric vector of length 2, interpreted as the coordinates of a single point. } In the last three cases, we need the second argument \code{W} which is converted to a window object by the function \code{\link{as.owin}}. In the first four cases, \code{W} will be ignored. If \code{X} is a line segment pattern (an object of class \code{psp}) the point pattern returned consists of the endpoints of the segments. If \code{X} is marked then the point pattern returned will also be marked, the mark associated with a point being the mark of the segment of which that point was an endpoint. If \code{X} is a matrix or data frame, the first and second columns will be interpreted as the \eqn{x} and \eqn{y} coordinates respectively. Any additional columns will be interpreted as marks. The argument \code{fatal} indicates what to do when \code{W} is missing and \code{X} contains no information about the window. If \code{fatal=TRUE}, a fatal error will be generated; if \code{fatal=FALSE}, the value \code{NULL} is returned. In the \pkg{spatial} library, a point pattern is represented in either of the following formats: \itemize{ \item (in \pkg{spatial} versions 1 to 6) a structure with entries \code{x}, \code{y} \code{xl}, \code{xu}, \code{yl}, \code{yu} \item (in \pkg{spatial} version 7) a structure with entries \code{x}, \code{y} and \code{area}, where \code{area} is a structure with entries \code{xl}, \code{xu}, \code{yl}, \code{yu} } where \code{x} and \code{y} are vectors of equal length giving the point coordinates, and \code{xl}, \code{xu}, \code{yl}, \code{yu} are numbers giving the dimensions of a rectangular window. Point pattern datasets can also be created by the function \code{\link{ppp}}. Methods for \code{as.ppp} exist for some other classes of data; they are listed by \code{methods(as.ppp)}. } \seealso{ \code{\link{ppp}}, \code{\link{ppp.object}}, \code{\link{as.owin}}, \code{\link{owin.object}}. Methods for \code{as.ppp} exist for some other classes of data; they are listed by \code{methods(as.ppp)}. } \examples{ xy <- matrix(runif(40), ncol=2) pp <- as.ppp(xy, c(0,1,0,1)) # Venables-Ripley format # check for 'spatial' package spatialpath <- system.file(package="spatial") if(nchar(spatialpath) > 0) { require(spatial) towns <- ppinit("towns.dat") pp <- as.ppp(towns) # converted to our format detach(package:spatial) } xyzt <- matrix(runif(40), ncol=4) Z <- as.ppp(xyzt, square(1)) } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} spatstat.geom/man/grow.rectangle.Rd0000644000176200001440000000325514611065346017041 0ustar liggesusers\name{grow.rectangle} \alias{grow.rectangle} \title{Add margins to rectangle} \description{ Adds a margin to a rectangle. } \usage{ grow.rectangle(W, xmargin=0, ymargin=xmargin, fraction=NULL) } \arguments{ \item{W}{ A window (object of class \code{"owin"}). Must be of type \code{"rectangle"}. } \item{xmargin}{Width of horizontal margin to be added. A single nonnegative number, or a vector of length 2 indicating margins of unequal width at left and right. } \item{ymargin}{Height of vertical margin to be added. A single nonnegative number, or a vector of length 2 indicating margins of unequal width at bottom and top. } \item{fraction}{ Fraction of width and height to be added. A number greater than zero, or a numeric vector of length 2 indicating different fractions of width and of height, respectively. Incompatible with specifying \code{xmargin} and \code{ymargin}. } } \value{ Another object of class \code{"owin"} representing the window after margins are added. } \details{ This is a simple convenience function to add a margin of specified width and height on each side of a rectangular window. Unequal margins can also be added. } \seealso{ \code{\link{trim.rectangle}}, \code{\link{dilation}}, \code{\link{erosion}}, \code{\link{owin.object}} } \examples{ w <- square(10) # add a margin of width 1 on all four sides square12 <- grow.rectangle(w, 1) # add margin of width 3 on the right side # and margin of height 4 on top. v <- grow.rectangle(w, c(0,3), c(0,4)) # grow by 5 percent on all sides grow.rectangle(w, fraction=0.05) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/angles.psp.Rd0000644000176200001440000000312714611065345016167 0ustar liggesusers\name{angles.psp} \alias{angles.psp} \title{Orientation Angles of Line Segments} \description{ Computes the orientation angle of each line segment in a line segment pattern. } \usage{ angles.psp(x, directed=FALSE) } \arguments{ \item{x}{ A line segment pattern (object of class \code{"psp"}). } \item{directed}{ Logical flag. See details. } } \value{ Numeric vector. } \details{ For each line segment, the angle of inclination to the \eqn{x}-axis (in radians) is computed, and the angles are returned as a numeric vector. If \code{directed=TRUE}, the directed angle of orientation is computed. The angle respects the sense of direction from \code{(x0,y0)} to \code{(x1,y1)}. The values returned are angles in the full range from \eqn{-\pi}{-\pi} to \eqn{\pi}{\pi}. The angle is computed as \code{atan2(y1-y0,x1-x0)}. See \code{\link{atan2}}. If \code{directed=FALSE}, the undirected angle of orientation is computed. Angles differing by \eqn{\pi} are regarded as equivalent. The values returned are angles in the range from \eqn{0} to \eqn{\pi}{\pi}. These angles are computed by first computing the directed angle, then adding \eqn{\pi}{\pi} to any negative angles. } \seealso{ \code{\link{psp}}, \code{\link{marks.psp}}, \code{\link{summary.psp}}, \code{\link{midpoints.psp}}, \code{\link{lengths_psp}}, \code{\link{endpoints.psp}}, \code{\link{extrapolate.psp}}. } \examples{ a <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) b <- angles.psp(a) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/crossdist.Rd0000644000176200001440000000252414611065345016132 0ustar liggesusers\name{crossdist} \alias{crossdist} \title{Pairwise distances} \description{ Computes the distances between pairs of `things' taken from two different datasets. } \usage{ crossdist(X, Y, \dots) } \arguments{ \item{X,Y}{ Two objects of the same class. } \item{\dots}{ Additional arguments depending on the method. } } \value{ A matrix whose \code{[i,j]} entry is the distance from the \code{i}-th thing in the first dataset to the \code{j}-th thing in the second dataset. } \details{ Given two datasets \code{X} and \code{Y} (representing either two point patterns or two line segment patterns) \code{crossdist} computes the Euclidean distance from each thing in the first dataset to each thing in the second dataset, and returns a matrix containing these distances. The function \code{crossdist} is generic, with methods for point patterns (objects of class \code{"ppp"}), line segment patterns (objects of class \code{"psp"}), and a default method. See the documentation for \code{\link{crossdist.ppp}}, \code{\link{crossdist.psp}} or \code{\link{crossdist.default}} for further details. } \seealso{ \code{\link{crossdist.ppp}}, \code{\link{crossdist.psp}}, \code{\link{crossdist.default}}, \code{\link{pairdist}}, \code{\link{nndist}} } \author{ \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/project2set.Rd0000644000176200001440000000314414643111575016362 0ustar liggesusers\name{project2set} \alias{project2set} \title{ Find Nearest Point in a Region } \description{ For each data point in a point pattern \code{X}, find the nearest location in a given spatial region \code{W}. } \usage{ project2set(X, W, \dots) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"}). } \item{W}{ Window (object of class \code{"owin"}) or something acceptable to \code{\link{as.owin}}. } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution. } } \details{ The window \code{W} is first discretised as a binary mask using \code{\link[spatstat.geom]{as.mask}}. For each data point \code{X[i]} in the point pattern \code{X}, the algorithm finds the nearest pixel in \code{W}. The result is a point pattern \code{Y} containing these nearest points, that is, \code{Y[i]} is the nearest point in \code{W} to the point \code{X[i]}. } \value{ A point pattern (object of class \code{"ppp"}) with the same number of points as \code{X} in the window \code{W}. } \author{\adrian \rolf and \ege } \seealso{ \code{\link{project2segment}}, \code{\link{nncross}} } \examples{ He <- heather$fine[owin(c(2.8, 7.4), c(4.0, 7.8))] plot(He, main="project2set") W <- erosion(complement.owin(He), 0.2) if(require(spatstat.random)) { X <- runifpoint(4, W) } else { X <- ppp(c(6.1, 4.3, 5.7, 4.7), c(5.0, 6.6, 7.5, 4.9), window=W) } points(X, col="red") Y <- project2set(X, He) points(Y, col="green") arrows(X$x, X$y, Y$x, Y$y, angle=15, length=0.2) } \keyword{spatial} \keyword{math} spatstat.geom/man/is.owin.Rd0000644000176200001440000000127114611065347015503 0ustar liggesusers\name{is.owin} \alias{is.owin} \title{Test Whether An Object Is A Window} \description{ Checks whether its argument is a window (object of class \code{"owin"}). } \usage{ is.owin(x) } \arguments{ \item{x}{Any object.} } \details{ This function tests whether the object \code{x} is a window object of class \code{"owin"}. See \code{\link{owin.object}} for details of this class. The result is determined to be \code{TRUE} if \code{x} inherits from \code{"owin"}, i.e. if \code{x} has \code{"owin"} amongst its classes. } \value{ \code{TRUE} if \code{x} is a point pattern, otherwise \code{FALSE}. } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/Extract.psp.Rd0000644000176200001440000000633614611065346016336 0ustar liggesusers\name{Extract.psp} \alias{[.psp} \title{Extract Subset of Line Segment Pattern} \description{ Extract a subset of a line segment pattern. } \usage{ \method{[}{psp}(x, i, j, drop, \dots, fragments=TRUE) } \arguments{ \item{x}{ A two-dimensional line segment pattern. An object of class \code{"psp"}. } \item{i}{ Subset index. Either a valid subset index in the usual \R sense, indicating which segments should be retained, or a window (an object of class \code{"owin"}) delineating a subset of the original observation window. } \item{j}{ Redundant - included for backward compatibility. } \item{drop}{ Ignored. Required for compatibility with generic function. } \item{\dots}{ Ignored. } \item{fragments}{ Logical value indicating whether to retain all pieces of line segments that intersect the new window (\code{fragments=TRUE}, the default) or to retain only those line segments that lie entirely inside the new window (\code{fragments=FALSE}). } } \value{ A line segment pattern (of class \code{"psp"}). } \details{ These functions extract a designated subset of a line segment pattern. The function \code{[.psp} is a method for \code{\link{[}} for the class \code{"psp"}. It extracts a designated subset of a line segment pattern, either by ``\emph{thinning}'' (retaining/deleting some line segments of a line segment pattern) or ``\emph{trimming}'' (reducing the window of observation to a smaller subregion and clipping the line segments to this boundary) or both. The pattern will be ``thinned'' if \code{subset} is specified. The line segments designated by \code{subset} will be retained. Here \code{subset} can be a numeric vector of positive indices (identifying the line segments to be retained), a numeric vector of negative indices (identifying the line segments to be deleted) or a logical vector of length equal to the number of line segments in the line segment pattern \code{x}. In the latter case, the line segments for which \code{subset[i]=TRUE} will be retained, and the others will be deleted. The pattern will be ``trimmed'' if \code{window} is specified. This should be an object of class \code{\link{owin}} specifying a window of observation to which the line segment pattern \code{x} will be trimmed. Line segments of \code{x} lying inside the new \code{window} will be retained unchanged. Line segments lying partially inside the new \code{window} and partially outside it will, by default, be clipped so that they lie entirely inside the window; but if \code{fragments=FALSE}, such segments will be removed. Both ``thinning'' and ``trimming'' can be performed together. } \seealso{ \code{\link{psp.object}}, \code{\link{owin.object}} } \examples{ a <- psp(runif(20),runif(20),runif(20),runif(20), window=owin()) plot(a) # thinning id <- sample(c(TRUE, FALSE), 20, replace=TRUE) b <- a[id] plot(b, add=TRUE, lwd=3) # trimming plot(a) w <- owin(c(0.1,0.7), c(0.2, 0.8)) b <- a[w] plot(b, add=TRUE, col="red", lwd=2) plot(w, add=TRUE) u <- a[w, fragments=FALSE] plot(u, add=TRUE, col="blue", lwd=3) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/spatstat.options.Rd0000644000176200001440000004016314611065350017447 0ustar liggesusers\name{spatstat.options} \alias{spatstat.options} \alias{reset.spatstat.options} \title{Internal Options in Spatstat Package} \description{ Allows the user to examine and reset the values of global parameters which control actions in the \pkg{spatstat} package. } \usage{ spatstat.options(...) reset.spatstat.options() } \arguments{ \item{\dots}{ Either empty, or a succession of parameter names in quotes, or a succession of \code{name=value} pairs. See below for the parameter names. } } \value{ Either a list of parameters and their values, or a single value. See Details. } \details{ The function \code{spatstat.options} allows the user to examine and reset the values of global parameters which control actions in the \pkg{spatstat} package. It is analogous to the system function \code{\link[base]{options}}. The function \code{reset.spatstat.options} resets all the global parameters in \pkg{spatstat} to their original, default values. The global parameters of interest to the user are: \describe{ \item{checkpolygons}{ Logical flag indicating whether the functions \code{\link{owin}} and \code{\link{as.owin}} should apply very strict checks on the validity of polygon data. These strict checks are no longer necessary, and the default is \code{checkpolygons=FALSE}. See also \code{fixpolygons} below. } \item{checksegments}{ Logical flag indicating whether the functions \code{\link{psp}} and \code{\link{as.psp}} should check the validity of line segment data (in particular, checking that the endpoints of the line segments are inside the specified window). It is advisable to leave this flag set to \code{TRUE}. } \item{dpp.maxmatrix}{ Integer specifying the maximum size of matrices generated by \code{\link[spatstat.model]{dppeigen}}. Defaults to \code{2^24}. } \item{eroded.intensity}{ Logical flag affecting the behaviour of the score and pseudo-score residual functions \code{\link[spatstat.model]{Gcom}}, \code{\link[spatstat.model]{Gres}} \code{\link[spatstat.model]{Kcom}}, \code{\link[spatstat.model]{Kres}}, \code{\link[spatstat.model]{psstA}}, \code{\link[spatstat.model]{psstG}}, \code{\link[spatstat.model]{psst}}. The flag indicates whether to compute intensity estimates on an eroded window (\code{eroded.intensity=TRUE}) or on the original data window (\code{eroded.intensity=FALSE}, the default). } \item{expand}{ The default expansion factor (area inflation factor) for expansion of the simulation window in \code{\link[spatstat.random]{rmh}} (see \code{\link[spatstat.random]{rmhcontrol}}). Initialised to \code{2}. } \item{expand.polynom}{ Logical. Whether expressions involving \code{\link[spatstat.model]{polynom}} in a model formula should be expanded, so that \code{polynom(x,2)} is replaced by \code{x + I(x^2)} and so on. Initialised to \code{TRUE}. } \item{fastpois}{ Logical. Whether to use a fast algorithm (introduced in \pkg{spatstat 1.42-3}) for simulating the Poisson point process in \code{\link[spatstat.random]{rpoispp}} when the argument \code{lambda} is a pixel image. Initialised to \code{TRUE}. Should be set to \code{FALSE} if needed to guarantee repeatability of results computed using earlier versions of \pkg{spatstat}. } \item{fastthin}{ Logical. Whether to use a fast C language algorithm (introduced in \pkg{spatstat 1.42-3}) for random thinning in \code{\link[spatstat.random]{rthin}} when the argument \code{P} is a single number. Initialised to \code{TRUE}. Should be set to \code{FALSE} if needed to guarantee repeatability of results computed using earlier versions of \pkg{spatstat}. } \item{fastK.lgcp}{ Logical. Whether to use fast or slow algorithm to compute the (theoretical) \eqn{K}-function of a log-Gaussian Cox process for use in \code{\link[spatstat.model]{lgcp.estK}} or \code{\link[spatstat.model]{Kmodel}}. The slow algorithm uses accurate numerical integration; the fast algorithm uses Simpson's Rule for numerical integration, and is about two orders of magnitude faster. Initialised to \code{FALSE}. } \item{fixpolygons}{ Logical flag indicating whether the functions \code{\link{owin}} and \code{\link{as.owin}} should repair errors in polygon data. For example, self-intersecting polygons and overlapping polygons will be repaired. The default is \code{fixpolygons=TRUE}. } \item{fftw}{ Logical value indicating whether the two-dimensional Fast Fourier Transform should be computed using the package \pkg{fftwtools}, instead of the \code{fft} function in the \pkg{stats} package. This affects the speed of \code{\link[spatstat.explore]{density.ppp}}, \code{\link[spatstat.explore]{density.psp}}, \code{\link[spatstat.explore]{blur}} \code{\link{setcov}} and \code{\link[spatstat.explore]{Smooth.ppp}}. } \item{gpclib}{ Defunct. This parameter was used to permit or forbid the use of the package \pkg{gpclib}, because of its restricted software licence. This package is no longer needed. } \item{huge.npoints}{ The maximum value of \code{n} for which \code{runif(n)} will not generate an error (possible errors include failure to allocate sufficient memory, and integer overflow of \code{n}). An attempt to generate more than this number of random points triggers a warning from \code{\link[spatstat.random]{runifpoint}} and other functions. Defaults to \code{1e6}. } \item{image.colfun}{ Function determining the default colour map for \code{\link{plot.im}}. When called with one integer argument \code{n}, this function should return a character vector of length \code{n} specifying \code{n} different colours. } \item{Kcom.remove.zeroes}{ Logical value, determining whether the algorithm in \code{\link[spatstat.model]{Kcom}} and \code{\link[spatstat.model]{Kres}} removes or retains the contributions to the function from pairs of points that are identical. If these are retained then the function has a jump at \eqn{r=0}. Initialised to \code{TRUE}. } \item{maxedgewt}{ Edge correction weights will be trimmed so as not to exceed this value. This applies to the weights computed by \code{\link[spatstat.explore]{edge.Trans}} or \code{\link[spatstat.explore]{edge.Ripley}} and used in \code{\link[spatstat.explore]{Kest}} and its relatives. } \item{maxmatrix}{ The maximum permitted size (rows times columns) of matrices generated by \pkg{spatstat}'s internal code. Used by \code{\link[spatstat.model]{ppm}} and \code{\link[spatstat.model]{predict.ppm}} (for example) to decide when to split a large calculation into blocks. Defaults to \code{2^24=16777216}. } \item{monochrome}{ Logical flag indicating whether graphics should be plotted in grey scale (\code{monochrome=TRUE}) or in colour (\code{monochrome=FALSE}, the default). } \item{n.bandwidth}{ Integer. Number of trial values of smoothing bandwidth to use for cross-validation in \code{\link[spatstat.explore]{bw.relrisk}} and similar functions. } \item{ndummy.min}{ The minimum number of dummy points in a quadrature scheme created by \code{\link{default.dummy}}. Either an integer or a pair of integers giving the minimum number of dummy points in the \code{x} and \code{y} directions respectively. } \item{ngrid.disc}{ Number of points in the square grid used to compute a discrete approximation to the areas of discs in \code{\link[spatstat.geom]{areaLoss}} and \code{\link[spatstat.geom]{areaGain}} when exact calculation is not available. A single integer. } \item{npixel}{ Default number of pixels in a binary mask or pixel image. Either an integer, or a pair of integers, giving the number of pixels in the \code{x} and \code{y} directions respectively. } \item{nvoxel}{ Default number of voxels in a 3D image, typically for calculating the distance transform in \code{\link[spatstat.explore]{F3est}}. Initialised to 4 megavoxels: \code{nvoxel = 2^22 = 4194304}. } \item{par.binary}{ List of arguments to be passed to the function \code{\link[graphics]{image}} when displaying a binary image mask (in \code{\link{plot.owin}} or \code{\link{plot.ppp}}). Typically used to reset the colours of foreground and background. } \item{par.contour}{ List of arguments controlling contour plots of pixel images by \code{\link{contour.im}}. } \item{par.fv}{ List of arguments controlling the plotting of functions by \code{\link[spatstat.explore]{plot.fv}} and its relatives. } \item{par.persp}{ List of arguments to be passed to the function \code{\link[graphics]{persp}} when displaying a real-valued image, such as the fitted surfaces in \code{\link[spatstat.model]{plot.ppm}}. } \item{par.points}{ List of arguments controlling the plotting of point patterns by \code{\link{plot.ppp}}. } \item{par.pp3}{ List of arguments controlling the plotting of three-dimensional point patterns by \code{\link{plot.pp3}}. } \item{print.ppm.SE}{ Default rule used by \code{\link[spatstat.model]{print.ppm}} to decide whether to calculate and print standard errors of the estimated coefficients of the model. One of the strings \code{"always"}, \code{"never"} or \code{"poisson"} (the latter indicating that standard errors will be calculated only for Poisson models). The default is \code{"poisson"} because the calculation for non-Poisson models can take a long time. } \item{progress}{ Character string determining the style of progress reports printed by \code{\link{progressreport}}. Either \code{"tty"}, \code{"tk"} or \code{"txtbar"}. For explanation of these options, see \code{\link{progressreport}}. } \item{project.fast}{ Logical. If \code{TRUE}, the algorithm of \code{\link[spatstat.model]{project.ppm}} will be accelerated using a shorcut. Initialised to \code{FALSE}. } \item{psstA.ngrid}{ Single integer, controlling the accuracy of the discrete approximation of areas computed in the function \code{\link[spatstat.model]{psstA}}. The area of a disc is approximated by counting points on an \eqn{n \times n}{n * n} grid. Initialised to 32. } \item{psstA.nr}{ Single integer, determining the number of distances \eqn{r} at which the function \code{\link[spatstat.model]{psstA}} will be evaluated (in the default case where argument \code{r} is absent). Initialised to 30. } \item{psstG.remove.zeroes}{ Logical value, determining whether the algorithm in \code{\link[spatstat.model]{psstG}} removes or retains the contributions to the function from pairs of points that are identical. If these are retained then the function has a jump at \eqn{r=0}. Initialised to \code{TRUE}. } \item{rmh.p, rmh.q, rmh.nrep}{ New default values for the parameters \code{p}, \code{q} and \code{nrep} in the Metropolis-Hastings simulation algorithm. These override the defaults in \code{\link[spatstat.random]{rmhcontrol.default}}. } \item{scalable}{ Logical flag indicating whether the new code in \code{\link[spatstat.random]{rmh.default}} which makes the results scalable (invariant to change of units) should be used. In order to recover former behaviour (so that previous results can be reproduced) set this option equal to \code{FALSE}. See the \dQuote{Warning} section in the help for \code{\link[spatstat.random]{rmh}()} for more detail. } \item{terse}{ Integer between 0 and 4. The level of terseness (brevity) in printed output from many functions in \pkg{spatstat}. Higher values mean shorter output. A rough guide is the following: \tabular{ll}{ 0 \tab Full output\cr 1 \tab Avoid wasteful output \cr 2 \tab Remove space between paragraphs\cr 3 \tab Suppress extras such as standard errors \cr 4 \tab Compress text, suppress internal warnings } The value of \code{terse} is initialised to 0. } \item{transparent}{ Logical value indicating whether default colour maps are allowed to include semi-transparent colours, where possible. Default is \code{TRUE}. Currently this only affects \code{\link{plot.ppp}}. } \item{units.paren}{ The kind of parenthesis which encloses the text that explains a \code{unitname}. This text is seen in the text output of functions like \code{\link{print.ppp}} and in the graphics generated by \code{\link[spatstat.explore]{plot.fv}}. The value should be one of the character strings \code{'('}, \code{'['}, \code{'{'} or \code{''}. The default is \code{'('}. } } If no arguments are given, the current values of all parameters are returned, in a list. If one parameter name is given, the current value of this parameter is returned (\bold{not} in a list, just the value). If several parameter names are given, the current values of these parameters are returned, in a list. If \code{name=value} pairs are given, the named parameters are reset to the given values, and the \bold{previous} values of these parameters are returned, in a list. } \section{Internal parameters}{ The following parameters may also be specified to \code{spatstat.options} but are intended for software development or testing purposes. \describe{ \item{closepairs.newcode}{ Logical. Whether to use new version of the code for \code{\link{closepairs}}. Initialised to \code{TRUE}. } \item{crossing.psp.useCall}{ Logical. Whether to use new version of the code for \code{\link{crossing.psp}}. Initialised to \code{TRUE}. } \item{crosspairs.newcode}{ Logical. Whether to use new version of the code for \code{\link{crosspairs}}. Initialised to \code{TRUE}. } \item{densityC}{ Logical. Indicates whether to use accelerated C code (\code{densityC=TRUE}) or interpreted R code (\code{densityC=FALSE}) to evaluate \code{density.ppp(X, at="points")}. Initialised to \code{TRUE}. } \item{exactdt.checks.data}{ Logical. Do not change this value, unless you are \adrian. } \item{fasteval}{ One of the strings \code{'off'}, \code{'on'} or \code{'test'} determining whether to use accelerated C code to evaluate the conditional intensity of a Gibbs model. Initialised to \code{'on'}. } \item{old.morpho.psp}{ Logical. Whether to use old R code for morphological operations. Initialise to \code{FALSE}. } \item{selfcrossing.psp.useCall}{ Logical. Whether to use new version of the code for \code{\link{selfcrossing.psp}}. Initialised to \code{TRUE}. } \item{use.Krect}{ Logical. Whether to use specialised code for the K-function in a rectangular window. Initialised to \code{TRUE}. } } } \seealso{ \code{\link[base]{options}} } \examples{ # save current values whatever they are oldopt <- spatstat.options() spatstat.options("npixel") spatstat.options(npixel=150) spatstat.options(npixel=c(100,200)) spatstat.options(par.binary=list(col=grey(c(0.5,1)))) spatstat.options(par.persp=list(theta=-30,phi=40,d=4)) # see help(persp.default) for other options # revert to the state at the beginning of these examples spatstat.options(oldopt) # revert to 'factory defaults' reset.spatstat.options() } \author{ \spatstatAuthors. } \keyword{spatial} spatstat.geom/man/nnfun.Rd0000644000176200001440000000556614611065347015254 0ustar liggesusers\name{nnfun} \Rdversion{1.1} \alias{nnfun} \alias{nnfun.ppp} \alias{nnfun.psp} \title{ Nearest Neighbour Index Map as a Function } \description{ Compute the nearest neighbour index map of an object, and return it as a function. } \usage{ nnfun(X, ...) \method{nnfun}{ppp}(X, ..., k=1, value=c("index", "mark")) \method{nnfun}{psp}(X, ..., value=c("index", "mark")) } \arguments{ \item{X}{ Any suitable dataset representing a two-dimensional collection of objects, such as a point pattern (object of class \code{"ppp"}) or a line segment pattern (object of class \code{"psp"}). } \item{k}{ A single integer. The \code{k}th nearest neighbour will be found. } \item{\dots}{ Extra arguments are ignored. } \item{value}{ String (partially matched) specifying whether to return the index of the neighbour (\code{value="index"}, the default) or the mark value of the neighbour (\code{value="mark"}). } } \details{ For a collection \eqn{X} of two dimensional objects (such as a point pattern or a line segment pattern), the \dQuote{nearest neighbour index function} of \eqn{X} is the mathematical function \eqn{f} such that, for any two-dimensional spatial location \eqn{(x,y)}, the function value \code{f(x,y)} is the index \eqn{i} identifying the closest member of \eqn{X}. That is, if \eqn{i = f(x,y)} then \eqn{X[i]} is the closest member of the collection \eqn{X} to the location \eqn{(x,y)}. The command \code{f <- nnfun(X)} returns a \emph{function} in the \R language, with arguments \code{x,y}, that represents the nearest neighbour index function of \code{X}. Evaluating the function \code{f} in the form \code{v <- f(x,y)}, where \code{x} and \code{y} are any numeric vectors of equal length containing coordinates of spatial locations, yields the indices of the nearest neighbours to these locations. If the argument \code{k} is specified then the \code{k}-th nearest neighbour will be found. The result of \code{f <- nnfun(X)} also belongs to the class \code{"funxy"} and to the special class \code{"nnfun"}. It can be printed and plotted immediately as shown in the Examples. A \code{nnfun} object can be converted to a pixel image using \code{\link{as.im}}. } \value{ A \code{function} with arguments \code{x,y}. The function also belongs to the class \code{"nnfun"} which has a method for \code{print}. It also belongs to the class \code{"funxy"} which has methods for \code{plot}, \code{contour} and \code{persp}. } \seealso{ \code{\link{distfun}}, \code{\link{plot.funxy}} } \examples{ f <- nnfun(cells) f plot(f) f(0.2, 0.3) g <- nnfun(cells, k=2) g(0.2, 0.3) plot(nnfun(amacrine, value="m")) L <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) h <- nnfun(L) h(0.2, 0.3) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/nearest.raster.point.Rd0000644000176200001440000000414514643111575020210 0ustar liggesusers\name{nearest.raster.point} \alias{nearest.raster.point} \title{Find Pixel Nearest to a Given Point} \description{ Given cartesian coordinates, find the nearest pixel. } \usage{ nearest.raster.point(x,y,w, indices=TRUE) } \arguments{ \item{x}{Numeric vector of \eqn{x} coordinates of any points} \item{y}{Numeric vector of \eqn{y} coordinates of any points} \item{w}{An image (object of class \code{"im"}) or a binary mask window (an object of class \code{"owin"} of type \code{"mask"}). } \item{indices}{Logical flag indicating whether to return the row and column indices, or the actual \eqn{x,y} coordinates. } } \value{ If \code{indices=TRUE}, a list containing two vectors \code{rr} and \code{cc} giving row and column positions (in the image matrix). If \code{indices=FALSE}, a list containing vectors \code{x} and \code{y} giving actual coordinates of the pixels. } \details{ The argument \code{w} should be either a pixel image (object of class \code{"im"}) or a window (an object of class \code{"owin"}, see \code{\link{owin.object}} for details) of type \code{"mask"}. The arguments \code{x} and \code{y} should be numeric vectors of equal length. They are interpreted as the coordinates of points in space. For each point \code{(x[i], y[i])}, the function finds the nearest pixel in the grid of pixels for \code{w}. If \code{indices=TRUE}, this function returns a list containing two vectors \code{rr} and \code{cc} giving row and column positions (in the image matrix). For the location \code{(x[i],y[i])} the nearest pixel is at row \code{rr[i]} and column \code{cc[i]} of the image. If \code{indices=FALSE}, the function returns a list containing two vectors \code{x} and \code{y} giving the actual coordinates of the pixels. } \seealso{ \code{\link{owin.object}}, \code{\link[spatstat.geom]{as.mask}} } \examples{ w <- owin(c(0,1), c(0,1), mask=matrix(TRUE, 100,100)) # 100 x 100 grid nearest.raster.point(0.5, 0.3, w) nearest.raster.point(0.5, 0.3, w, indices=FALSE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/maxnndist.Rd0000644000176200001440000000341614611065347016125 0ustar liggesusers\name{maxnndist} \alias{maxnndist} \alias{minnndist} \title{ Compute Minimum or Maximum Nearest-Neighbour Distance } \description{ A faster way to compute the minimum or maximum nearest-neighbour distance in a point pattern. } \usage{ minnndist(X, positive=FALSE, by=NULL) maxnndist(X, positive=FALSE, by=NULL) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"}). } \item{positive}{ Logical. If \code{FALSE} (the default), compute the usual nearest-neighbour distance. If \code{TRUE}, ignore coincident points, so that the nearest neighbour distance for each point is greater than zero. } \item{by}{ Optional. A factor, which separates \code{X} into groups. The algorithm will compute the distance to the nearest point in each group. } } \details{ These functions find the minimum and maximum values of nearest-neighbour distances in the point pattern \code{X}. \code{minnndist(X)} and \code{maxnndist(X)} are equivalent to, but faster than, \code{min(nndist(X))} and \code{max(nndist(X))} respectively. The value is \code{NA} if \code{npoints(X) < 2}. } \value{ A single numeric value (possibly \code{NA}). If \code{by} is given, the result is a numeric matrix giving the minimum or maximum nearest neighbour distance between each subset of \code{X}. } \seealso{ \code{\link{nndist}} } \examples{ min(nndist(swedishpines)) minnndist(swedishpines) max(nndist(swedishpines)) maxnndist(swedishpines) minnndist(lansing, positive=TRUE) if(interactive()) { X <- runifrect(1e6) system.time(min(nndist(X))) system.time(minnndist(X)) } minnndist(amacrine, by=marks(amacrine)) maxnndist(amacrine, by=marks(amacrine)) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/grow.boxx.Rd0000644000176200001440000000250214611065346016047 0ustar liggesusers\name{grow.boxx} \alias{grow.boxx} \alias{grow.box3} \title{Add margins to box in any dimension} \description{ Adds a margin to a box of class boxx. } \usage{ grow.boxx(W, left, right = left) grow.box3(W, left, right = left) } \arguments{ \item{W}{ A box (object of class \code{"boxx"} or \code{"box3"}). } \item{left}{Width of margin to be added to left endpoint of box side in every dimension. A single nonnegative number, or a vector of same length as the dimension of the box to add different left margin in each dimension. } \item{right}{Width of margin to be added to right endpoint of box side in every dimension. A single nonnegative number, or a vector of same length as the dimension of the box to add different right margin in each dimension. } } \value{ Another object of the same class \code{"boxx"} or \code{"box3"} representing the window after margins are added. } \seealso{ \code{\link{grow.rectangle}}, \code{\link{boxx}}, \code{\link{box3}} } \examples{ w <- boxx(c(0,10), c(0,10), c(0,10), c(0,10)) # add a margin of size 1 on both sides in all four dimensions b12 <- grow.boxx(w, 1) # add margin of size 2 at left, and margin of size 3 at right, # in each dimension. v <- grow.boxx(w, 2, 3) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/distmap.psp.Rd0000644000176200001440000000752314742317357016373 0ustar liggesusers\name{distmap.psp} \alias{distmap.psp} \title{ Distance Map of Line Segment Pattern } \description{ Computes the distance from each pixel to the nearest line segment in the given line segment pattern. } \usage{ \method{distmap}{psp}(X, \dots, extras=TRUE, clip=FALSE, metric=NULL) } \arguments{ \item{X}{A line segment pattern (object of class \code{"psp"}). } \item{\dots}{Arguments passed to \code{\link[spatstat.geom]{as.mask}} to control pixel resolution. } \item{extras}{ Logical value specifying whether to compute the additional attributes \code{"index"} and \code{"bdry"} described in Details. } \item{clip}{ Logical value specifying whether the resulting pixel image should be clipped to the window of \code{X}. } \item{metric}{ Optional. A distance metric (object of class \code{"metric"}, see \code{\link{metric.object}}) which will be used to compute the distances. } } \value{ A pixel image (object of class \code{"im"}) whose greyscale values are the values of the distance map. The return value has attributes \code{"index"} and \code{"bdry"} which are also pixel images. } \details{ The ``distance map'' of a line segment pattern \eqn{X} is the function \eqn{f} whose value \code{f(u)} is defined for any two-dimensional location \eqn{u} as the shortest distance from \eqn{u} to \eqn{X}. This function computes the distance map of the line segment pattern \code{X} and returns the distance map as a pixel image. The greyscale value at a pixel \eqn{u} equals the distance from \eqn{u} to the nearest line segment of the pattern \code{X}. Distances are computed using analytic geometry. The result is a pixel image. If \code{clip=FALSE} (the default), the pixel values are defined at every pixel in the rectangle \code{Frame(X)}. If \code{clip=TRUE}, the pixel values are defined only inside \code{Window(X)}, and are \code{NA} outside this window. Computation is faster when \code{clip=FALSE}. Additionally, if \code{extras=TRUE}, the return value has two attributes, \code{"index"} and \code{"bdry"}, which are also pixel images. The pixels values of \code{"bdry"} give the distance from each pixel to the boundary of the window of \code{X} (and are zero outside this window). The pixel values of \code{"index"} are integers identifying which line segment of \code{X} is closest. If \code{clip=FALSE} (the default), these images are defined at every pixel in \code{Frame(X)}; if \code{clip=TRUE}, they are clipped to the window of \code{X}. Computation is faster when \code{extras=FALSE}. This is a method for the generic function \code{\link{distmap}}. Note that this function gives the exact distance from the \emph{centre of each pixel} to the nearest line segment. To compute the exact distance from the points in a point pattern to the nearest line segment, use \code{\link{distfun}} or one of the low-level functions \code{\link{nncross}} or \code{\link{project2segment}}. } \section{Distance values}{ The pixel values in the image \code{distmap(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values in \code{distmap(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{distmap}}, \code{\link{distmap.owin}}, \code{\link{distmap.ppp}}, \code{\link{distfun}}, \code{\link{nncross}}, \code{\link{nearestsegment}}, \code{\link{project2segment}}. } \examples{ a <- psp(runif(20),runif(20),runif(20),runif(20), window=owin()) Z <- distmap(a) plot(Z) plot(a, add=TRUE) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/relevel.im.Rd0000644000176200001440000000256014611065350016153 0ustar liggesusers\name{relevel.im} \alias{relevel.im} \alias{relevel.ppp} \alias{relevel.ppx} \title{ Reorder Levels of a Factor-Valued Image or Pattern } \description{ For a pixel image with factor values, or a point pattern with factor-valued marks, the levels of the factor are re-ordered so that the level \code{ref} is first and the others are moved down. } \usage{ \method{relevel}{im}(x, ref, \dots) \method{relevel}{ppp}(x, ref, \dots) \method{relevel}{ppx}(x, ref, \dots) } \arguments{ \item{x}{ A pixel image (object of class \code{"im"}) with factor values, or a point pattern (object of class \code{"ppp"}, \code{"ppx"}, \code{"lpp"} or \code{"pp3"}) with factor-valued marks. } \item{ref}{ The reference level. } \item{\dots}{ Ignored. } } \details{ These functions are methods for the generic \code{\link[stats]{relevel}}. If \code{x} is a pixel image (object of class \code{"im"}) with factor values, or a point pattern (object of class \code{"ppp"}, \code{"ppx"}, \code{"lpp"} or \code{"pp3"}) with factor-valued marks, the levels of the factor are changed so that the level specified by \code{ref} comes first. } \value{ Object of the same kind as \code{x}. } \author{ \adrian \rolf and \ege } \seealso{ \code{\link{mergeLevels}} } \examples{ amacrine relevel(amacrine, "on") } \keyword{manip} \keyword{spatial} spatstat.geom/man/is.connected.Rd0000644000176200001440000000253014611065346016467 0ustar liggesusers\name{is.connected} \Rdversion{1.1} \alias{is.connected} \alias{is.connected.default} \title{ Determine Whether an Object is Connected } \description{ Determine whether an object is topologically connected. } \usage{ is.connected(X, \dots) \method{is.connected}{default}(X, \dots) } \arguments{ \item{X}{ A spatial object such as a pixel image (object of class \code{"im"}), or a window (object of class \code{"owin"}). } \item{\dots}{ Arguments passed to \code{\link{connected}} to determine the connected components. } } \details{ The command \code{is.connected(X)} returns \code{TRUE} if the object \code{X} consists of a single, topologically-connected piece, and returns \code{FALSE} if \code{X} consists of several pieces which are not joined together. The function \code{is.connected} is generic. The default method \code{is.connected.default} works for many classes of objects, including windows (class \code{"owin"}) and images (class \code{"im"}). There is a method for point patterns, described in \code{\link{is.connected.ppp}}. } \value{ A logical value. } \seealso{ \code{\link{connected}}, \code{\link{is.connected.ppp}}. } \examples{ d <- distmap(cells, dimyx=256) X <- levelset(d, 0.07) plot(X) is.connected(X) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/scaletointerval.Rd0000644000176200001440000000262414611065350017311 0ustar liggesusers\name{scaletointerval} \alias{scaletointerval} \alias{scaletointerval.default} \alias{scaletointerval.im} \title{Rescale Data to Lie Between Specified Limits} \description{ Rescales a dataset so that the values range exactly between the specified limits. } \usage{ scaletointerval(x, from=0, to=1, xrange=range(x)) \method{scaletointerval}{default}(x, from=0, to=1, xrange=range(x)) \method{scaletointerval}{im}(x, from=0, to=1, xrange=range(x)) } \arguments{ \item{x}{Data to be rescaled.} \item{from,to}{Lower and upper endpoints of the interval to which the values of \code{x} should be rescaled. } \item{xrange}{ Optional range of values of \code{x} that should be mapped to the new interval. } } \details{ These functions rescale a dataset \code{x} so that its values range exactly between the limits \code{from} and \code{to}. The method for pixel images (objects of class \code{"im"}) applies this scaling to the pixel values of \code{x}. Rescaling cannot be performed if the values in \code{x} are not interpretable as numeric, or if the values in \code{x} are all equal. } \value{ An object of the same type as \code{x}. } \seealso{ \code{\link{scale}} } \examples{ X <- as.im(function(x,y) {x+y+3}, unit.square()) summary(X) Y <- scaletointerval(X) summary(Y) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} \keyword{univar} spatstat.geom/man/methods.unitname.Rd0000644000176200001440000000610614611065347017401 0ustar liggesusers\name{methods.unitname} \Rdversion{1.1} \alias{methods.unitname} %DoNotExport \alias{print.unitname} \alias{summary.unitname} \alias{rescale.unitname} \alias{compatible.unitname} \alias{harmonise.unitname} \alias{harmonize.unitname} \title{ Methods for Units } \description{ Methods for class \code{"unitname"}. } \usage{ \method{print}{unitname}(x, ...) \method{summary}{unitname}(object, ...) \method{rescale}{unitname}(X, s, unitname) \method{compatible}{unitname}(A,B, ..., coerce=TRUE) \method{harmonise}{unitname}(..., coerce=TRUE, single=FALSE) \method{harmonize}{unitname}(..., coerce=TRUE, single=FALSE) } \arguments{ \item{x,X,A,B,object}{ Objects of class \code{"unitname"} representing units of length. } \item{\dots}{ Other arguments. For \code{print.unitname} these arguments are passed to \code{\link[base]{print.default}}. For \code{summary.unitname} they are ignored. For \code{compatible.unitname} and \code{harmonise.unitname} these arguments are other objects of class \code{"unitname"}. } \item{s}{ Conversion factor: the new units are \code{s} times the old units. } \item{unitname}{ Optional new name for the unit. If present, this overrides the rescaling operation and simply substitutes the new name for the old one. } \item{coerce}{ Logical. If \code{TRUE}, a null unit of length is compatible with any non-null unit. } \item{single}{ Logical value indicating whether to return a single unitname, or a list of unitnames. } } \details{ These are methods for the generic functions \code{\link{print}}, \code{\link{summary}}, \code{\link{rescale}} and \code{\link{compatible}} for the class \code{"unitname"}. An object of class \code{"unitname"} represents a unit of length. The \code{print} method prints a description of the unit of length, and the \code{summary} method gives a more detailed description. The \code{rescale} method changes the unit of length by rescaling it. The \code{compatible} method tests whether two or more units of length are compatible. The \code{harmonise} method returns the common unit of length if there is one. For consistency with other methods for \code{\link{harmonise}}, the result is a list of unitname objects, with one entry for each argument in \code{\dots}. All of these entries are identical. This can be overridden by setting \code{single=TRUE} when the result will be a single unitname object. } \value{ For \code{print.unitname} the value is \code{NULL}. For \code{summary.unitname} the value is an object of class \code{summary.unitname} (with its own print method). For \code{rescale.unitname} the value is another object of class \code{"unitname"}. For \code{compatible.unitname} the result is logical. For \code{harmonise.unitname} the result is a list of identical unitnames if \code{single=FALSE} (the default), or a single unitname if \code{single=TRUE}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{box3}}, \code{\link{print}}, \code{\link{unitname}} } \keyword{spatial} \keyword{methods} spatstat.geom/man/textureplot.Rd0000644000176200001440000000666314611065351016521 0ustar liggesusers\name{textureplot} \alias{textureplot} \title{ Plot Image or Tessellation Using Texture Fill } \description{ For a factor-valued pixel image, this command plots each level of the factor using a different texture. For a tessellation, each tile is plotted using a different texture. } \usage{ textureplot(x, \dots, main, add=FALSE, clipwin=NULL, do.plot = TRUE, border=NULL, col = NULL, lwd = NULL, lty = NULL, spacing = NULL, textures=1:8, legend=TRUE, leg.side=c("right", "left", "bottom", "top"), legsep=0.1, legwid=0.2) } \arguments{ \item{x}{ A tessellation (object of class \code{"tess"} or something acceptable to \code{\link{as.tess}}) with at most 8 tiles, or a pixel image (object of class \code{"im"} or something acceptable to \code{\link{as.im}}) whose pixel values are a \code{factor} with at most 8 levels. } \item{\dots}{ Other arguments passed to \code{\link{add.texture}}. } \item{main}{ Character string giving a main title for the plot. } \item{add}{ Logical value indicating whether to draw on the current plot (\code{add=TRUE}) or to initialise a new plot (\code{add=FALSE}). } \item{clipwin}{ Optional. A window (object of class \code{"owin"}). Only this subset of the image will be displayed. } \item{do.plot}{ Logical. Whether to actually do the plot. } \item{border}{ Colour for drawing the boundaries between the different regions. The default (\code{border=NULL}) means to use \code{par("fg")}. Use \code{border=NA} to omit borders. } \item{col}{ Numeric value or vector giving the colour or colours in which the textures should be plotted. } \item{lwd}{ Numeric value or vector giving the line width or widths to be used. } \item{lty}{ Numeric value or vector giving the line type or types to be used. } \item{spacing}{ Numeric value or vector giving the \code{spacing} parameter for the textures. } \item{textures}{ Textures to be used for each level. Either a texture map (object of class \code{"texturemap"}) or a vector of integer codes (to be interpreted by \code{\link{add.texture}}). } \item{legend}{ Logical. Whether to display an explanatory legend. } \item{leg.side}{Position of legend relative to main plot.} \item{legsep}{ Separation between legend and main plot, as a fraction of the shortest side length of the main plot. } \item{legwid}{ Width (if vertical) or height (if horizontal) of the legend as a fraction of the shortest side length of the main plot. } } \details{ If \code{x} is a tessellation, then each tile of the tessellation is plotted and filled with a texture using \link{add.texture}. If \code{x} is a factor-valued pixel image, then for each level of the factor, the algorithm finds the region where the image takes this value, and fills the region with a texture using \code{\link{add.texture}}. } \value{ (Invisible) A texture map (object of class \code{"texturemap"}) associating a texture with each level of the factor. } \author{ \spatstatAuthors. } \seealso{ \code{\link{im}}, \code{\link{plot.im}}, \code{\link{add.texture}}. } \examples{ nd <- if(interactive()) 128 else 32 Z <- setcov(owin(), dimyx=nd) Zcut <- cut(Z, 3, labels=c("Lo", "Med", "Hi")) textureplot(Zcut) textureplot(dirichlet(runifrect(6))) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/invoke.metric.Rd0000644000176200001440000000546414611065346016701 0ustar liggesusers\name{invoke.metric} \alias{invoke.metric} \title{ Perform Geometric Task using a Specified Metric } \description{ Perform a desired geometrical operation using a specified distance metric. } \usage{ invoke.metric(m, task, \dots, evaluate=TRUE) } \arguments{ \item{m}{ Metric (object of class \code{"metric"}) } \item{task}{ Character string specifying the task. The name of a function that performs the desired operation for the Euclidean metric. } \item{\dots}{ Input to the function that performs the geometrical operation (matching the arguments of \code{task}). } \item{evaluate}{ Logical value specifying whether to actually perform the computation and return the result (\code{evaluate=TRUE}, the default) or to simply return the function which performs the computation (\code{evaluate=FALSE}). } } \details{ A \sQuote{metric} is a measure of distance between points in space. An object of class \code{"metric"} represents such a metric, and supports many geometrical computations that involve the metric. See \code{\link{metric.object}}. The argument \code{task} should be the name of an existing function in the \pkg{spatstat} family representing a geometrical operation, such as computing pairwise distances, nearest-neighbour distances, the distance map, and so on. The code will determine whether this geometrical operation has a counterpart using the specified metric, that is defined and supported in the object \code{m}. If so, then this operation will be applied to the data specified in \code{\dots}, and the result will be returned. For example, the \pkg{spatstat} function \code{\link{nndist.ppp}} computes nearest-neighbour distances using the Euclidean distance metric. To calculate nearest-neighbour distances for a point pattern \code{X} using another metric \code{m}, use \code{invoke.metric(m, "nndist.ppp", X)}. If \code{evaluate=FALSE}, the computation is not performed, and \code{invoke.metric} simply returns a function to perform the desired operation. } \value{ If \code{evaluate=TRUE} (the default), the result of the computation has the same format as the result of the computation using the existing function named \code{task}. If \code{evaluate=FALSE}, the result is a \code{function} in the \R language to perform the desired operation; or \code{NULL} if the operation is not supported by the metric. } \author{ \adrian. } \seealso{ \code{\link{convexmetric}} } \examples{ ## nearest-neighbour distances using rectangular metric (L^1 metric) d <- convexmetric(square(c(-1,1))) y <- invoke.metric(d, "nndist.ppp", cells) f <- invoke.metric(d, "nndist.ppp", cells, evaluate=FALSE) y <- f(cells) invoke.metric(d, "orderPizza", evaluate=FALSE) } \keyword{spatial} \keyword{math} \concept{metric} spatstat.geom/man/plot.onearrow.Rd0000644000176200001440000000474314611065347016735 0ustar liggesusers\name{plot.onearrow} \alias{plot.onearrow} \title{Plot an Arrow} \description{Plots an object of class \code{"onearrow"}.} \usage{ \method{plot}{onearrow}(x, \dots, add = FALSE, main = "", retract = 0.05, headfraction = 0.25, headangle = 12, headnick = 0.1, col.head = NA, lwd.head = lwd, lwd = 1, col = 1, zap = FALSE, zapfraction = 0.07, pch = 1, cex = 1, do.plot = TRUE, do.points = FALSE, show.all = !add) } \arguments{ \item{x}{ Object of class \code{"onearrow"} to be plotted. This object is created by the command \code{\link{onearrow}}. } \item{\dots}{ Additional graphics arguments passed to \code{\link[graphics]{segments}} to control the appearance of the line. } \item{add}{Logical value indicating whether to add graphics to the existing plot (\code{add=TRUE}) or to start a new plot (\code{add=FALSE}). } \item{main}{Main title for the plot.} \item{retract}{ Fraction of length of arrow to remove at each end. } \item{headfraction}{ Length of arrow head as a fraction of overall length of arrow. } \item{headangle}{ Angle (in degrees) between the outer edge of the arrow head and the shaft of the arrow. } \item{headnick}{ Size of the nick in the trailing edge of the arrow head as a fraction of length of arrow head. } \item{col.head,lwd.head}{ Colour and line style of the filled arrow head. } \item{col,lwd}{ Colour and line style of the arrow shaft. } \item{zap}{ Logical value indicating whether the arrow should include a Z-shaped (lightning-bolt) feature in the middle of the shaft. } \item{zapfraction}{ Size of Z-shaped deviation as a fraction of total arrow length. } \item{pch,cex}{ Plot character and character size for the two end points of the arrow, if \code{do.points=TRUE}. } \item{do.plot}{ Logical. Whether to actually perform the plot. } \item{do.points}{ Logical. Whether to display the two end points of the arrow as well. } \item{show.all}{ Internal use only. } } \details{ The argument \code{x} should be an object of class \code{"onearrow"} created by the command \code{\link{onearrow}}. } \value{ A window (class \code{"owin"}) enclosing the plotted graphics. } \examples{ oa <- onearrow(cells[c(1, 42)]) oa plot(oa) plot(oa, zap=TRUE, do.points=TRUE, col.head="pink", col="red") } \author{ \spatstatAuthors. } \seealso{ \code{\link{onearrow}}, \code{\link{yardstick}} } \keyword{spatial} \keyword{hplot} spatstat.geom/man/tiles.empty.Rd0000644000176200001440000000247514611065351016374 0ustar liggesusers\name{tiles.empty} \alias{tiles.empty} \title{Check For Empty Tiles in a Tessellation} \description{ Checks whether each tile in a tessellation is empty or non-empty. } \usage{ tiles.empty(x) } \arguments{ \item{x}{A tessellation (object of class \code{"tess"}).} } \details{ A tessellation is a collection of disjoint spatial regions (called \emph{tiles}) that fit together to form a larger spatial region. See \code{\link{tess}}. It is possible for some tiles of a tessellation to be empty. For example, this can happen when the tessellation \code{x} is obtained by restricting another tessellation \code{y} to a smaller spatial domain \code{w}. The function \code{tiles.empty} checks whether each tile is empty or non-empty. The result is a logical vector, with entries equal to \code{TRUE} when the corresponding tile is empty. Results are given in the same order as the tiles would be listed by \code{tiles(x)}. } \value{ A logical vector. } \seealso{ \code{\link{tess}}, \code{\link{tiles}}, \code{\link{tilenames}}, \code{\link{tile.areas}} } \examples{ A <- tess(xgrid=0:2,ygrid=0:2) tiles.empty(A) v <- as.im(function(x,y){factor(round(x^2 + y^2))}, W=owin()) E <- tess(image=v) tiles.empty(E) } \author{ \adrian \rolf and \ege } \keyword{spatial} \keyword{manip} spatstat.geom/man/timed.Rd0000644000176200001440000000557014611065351015220 0ustar liggesusers\name{timed} \alias{timed} \title{ Record the Computation Time } \description{ Saves the result of a calculation as an object of class \code{"timed"} which includes information about the time taken to compute the result. The computation time is printed when the object is printed. } \usage{ timed(x, ..., starttime = NULL, timetaken = NULL) } \arguments{ \item{x}{ An expression to be evaluated, or an object that has already been evaluated. } \item{starttime}{ The time at which the computation is defined to have started. The default is the current time. Ignored if \code{timetaken} is given. } \item{timetaken}{ The length of time taken to perform the computation. The default is the time taken to evaluate \code{x}. } \item{\dots}{ Ignored. } } \details{ This is a simple mechanism for recording how long it takes to perform complicated calculations (usually for the purposes of reporting in a publication). If \code{x} is an expression to be evaluated, \code{timed(x)} evaluates the expression and measures the time taken to evaluate it. The result is saved as an object of the class \code{"timed"}. Printing this object displays the computation time. If \code{x} is an object which has already been computed, then the time taken to compute the object can be specified either directly by the argument \code{timetaken}, or indirectly by the argument \code{starttime}. \itemize{ \item \code{timetaken} is the duration of time taken to perform the computation. It should be the difference of two clock times returned by \code{\link{proc.time}}. Typically the user sets \code{begin <- proc.time()} before commencing the calculations, then \code{end <- proc.time()} after completing the calculations, and then sets \code{timetaken <- end - begin}. \item \code{starttime} is the clock time at which the computation started. It should be a value that was returned by \code{\link{proc.time}} at some earlier time when the calculations commenced. When \code{timed} is called, the computation time will be taken as the difference between the current clock time and \code{starttime}. Typically the user sets \code{begin <- proc.time()} before commencing the calculations, and when the calculations are completed, the user calls \code{result <- timed(result, starttime=begin)}. } If the result of evaluating \code{x} belongs to other S3 classes, then the result of \code{timed(x, \dots)} also inherits these classes, and printing the object will display the appropriate information for these classes as well. } \value{ An object inheriting the class \code{"timed"}. } \examples{ timed(minnndist(cells)) answer <- timed(42, timetaken=4.1e17) answer } \seealso{ \code{\link{timeTaken}} to extract the time taken. } \author{ \spatstatAuthors. } \keyword{utilities} spatstat.geom/man/pairdist.pp3.Rd0000644000176200001440000000474714742317357016456 0ustar liggesusers\name{pairdist.pp3} \alias{pairdist.pp3} \title{Pairwise distances in Three Dimensions} \description{ Computes the matrix of distances between all pairs of points in a three-dimensional point pattern. } \usage{ \method{pairdist}{pp3}(X, \dots, periodic=FALSE, squared=FALSE) } \arguments{ \item{X}{ A point pattern (object of class \code{"pp3"}). } \item{\dots}{ Ignored. } \item{periodic}{ Logical. Specifies whether to apply a periodic edge correction. } \item{squared}{ Logical. If \code{squared=TRUE}, the squared distances are returned instead (this computation is faster). } } \value{ A square matrix whose \code{[i,j]} entry is the distance between the points numbered \code{i} and \code{j}. } \details{ This is a method for the generic function \code{pairdist}. Given a three-dimensional point pattern \code{X} (an object of class \code{"pp3"}), this function computes the Euclidean distances between all pairs of points in \code{X}, and returns the matrix of distances. Alternatively if \code{periodic=TRUE} and the window containing \code{X} is a box, then the distances will be computed in the \sQuote{periodic} sense (also known as \sQuote{torus} distance): opposite faces of the box are regarded as equivalent. This is meaningless if the window is not a box. If \code{squared=TRUE} then the \emph{squared} Euclidean distances \eqn{d^2} are returned, instead of the Euclidean distances \eqn{d}. The squared distances are faster to calculate, and are sufficient for many purposes (such as finding the nearest neighbour of a point). } \section{Distance values}{ The values returned by \code{pairdist(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{pairdist(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{pairdist}}, \code{\link{crossdist}}, \code{\link{nndist}}, \code{\link[spatstat.explore]{K3est}} } \examples{ if(require(spatstat.random)) { X <- runifpoint3(20) } else { X <- osteo$pts[[1]] } d <- pairdist(X) d <- pairdist(X, periodic=TRUE) d <- pairdist(X, squared=TRUE) } \author{ \adrian based on two-dimensional code by \pavel. } \keyword{spatial} \keyword{math} \concept{Three-dimensional} spatstat.geom/man/intensity.psp.Rd0000644000176200001440000000477014611065346016752 0ustar liggesusers\name{intensity.psp} \alias{intensity.psp} \title{ Empirical Intensity of Line Segment Pattern } \description{ Computes the average total length of segments per unit area in a spatial pattern of line segments. } \usage{ \method{intensity}{psp}(X, ..., weights=NULL) } \arguments{ \item{X}{ A line segment pattern (object of class \code{"psp"}). } \item{weights}{ Optional. Numeric vector of weights attached to the segments of \code{X}. Alternatively, an \code{expression} which can be evaluated to give a vector of weights. } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link{intensity}}. It computes the empirical intensity of a line segment pattern (object of class \code{"psp"}), i.e. the average total segment length per unit area. If the segment pattern is multitype, the intensities of the different types are computed separately. Note that the intensity will be computed as the length per area in units per square unit, based on the unit of length for \code{X}, given by \code{unitname(X)}. If the unit of length is a strange multiple of a standard unit, like \code{5.7 metres}, then it can be converted to the standard unit using \code{\link{rescale}}. See the Examples. If \code{weights} are given, then the intensity is computed as the total \emph{weight times length} per square unit. The argument \code{weights} should be a numeric vector of weights for each point of \code{X} (weights may be negative or zero). Alternatively \code{weights} can be an \code{expression} which will be evaluated for the dataset to yield a vector of weights. The expression may involve the Cartesian coordinates \eqn{x,y} of the points, and the marks of the points, if any. Variable names permitted in the expression include \code{x0}, \code{x1}, \code{y0}, \code{y1} for the coordinates of the segment endpoint, the name \code{marks} if \code{X} has a single column of marks, the names of any columns of marks if \code{X} has a data frame of marks, and the names of constants or functions that exist in the global environment. See the Examples. } \value{ A numeric value (giving the intensity) or numeric vector (giving the intensity for each possible type). } \seealso{ \code{\link{intensity}} } \examples{ S <- edges(letterR) intensity(S) intensity(S, weights=runif(nsegments(S))) intensity(S, weights=expression((x0+x1)/2)) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{nonparametric} spatstat.geom/man/gridweights.Rd0000644000176200001440000000437714643111575016447 0ustar liggesusers\name{gridweights} \alias{gridweights} \title{Compute Quadrature Weights Based on Grid Counts} \description{ Computes quadrature weights for a given set of points, using the ``counting weights'' for a grid of rectangular tiles. } \usage{ gridweights(X, ntile, \dots, window=NULL, verbose=FALSE, npix=NULL, areas=NULL) } \arguments{ \item{X}{Data defining a point pattern.} \item{ntile}{Number of tiles in each row and column of the rectangular grid. An integer vector of length 1 or 2. } \item{\dots}{Ignored.} \item{window}{Default window for the point pattern} \item{verbose}{Logical flag. If \code{TRUE}, information will be printed about the computation of the grid weights. } \item{npix}{Dimensions of pixel grid to use when computing a digital approximation to the tile areas. } \item{areas}{Vector of areas of the tiles, if they are already known.} } \value{ Vector of nonnegative weights for each point in \code{X}. } \details{ This function computes a set of quadrature weights for a given pattern of points (typically comprising both ``data'' and `dummy'' points). See \code{\link{quad.object}} for an explanation of quadrature weights and quadrature schemes. The weights are computed by the ``counting weights'' rule based on a regular grid of rectangular tiles. First \code{X} and (optionally) \code{window} are converted into a point pattern object. Then the bounding rectangle of the window of the point pattern is divided into a regular \code{ntile[1] * ntile[2]} grid of rectangular tiles. The weight attached to a point of \code{X} is the area of the tile in which it lies, divided by the number of points of \code{X} lying in that tile. For non-rectangular windows the tile areas are currently calculated by approximating the window as a binary mask. The accuracy of this approximation is controlled by \code{npix}, which becomes the argument \code{dimyx} of \code{\link[spatstat.geom]{as.mask}}. } \seealso{ \code{\link{quad.object}}, \code{\link{dirichletWeights}} } \examples{ Q <- quadscheme(runifrect(15)) X <- as.ppp(Q) # data and dummy points together w <- gridweights(X, 10) w <- gridweights(X, c(10, 10)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/gridcentres.Rd0000644000176200001440000000360214611065346016425 0ustar liggesusers\name{gridcentres} \alias{gridcentres} \alias{gridcenters} \title{Rectangular grid of points} \description{ Generates a rectangular grid of points in a window } \usage{ gridcentres(window, nx, ny) } \arguments{ \item{window}{A window. An object of class \code{\link{owin}}, or data in any format acceptable to \code{\link{as.owin}()}. } \item{nx}{Number of points in each row of the rectangular grid. } \item{ny}{Number of points in each column of the rectangular grid. } } \value{ A list with two components \code{x} and \code{y}, which are numeric vectors giving the coordinates of the points of the rectangular grid. } \details{ This function creates a rectangular grid of points in the window. The bounding rectangle of the \code{window} is divided into a regular \eqn{nx \times ny}{nx * ny} grid of rectangular tiles. The function returns the \eqn{x,y} coordinates of the centres of these tiles. Note that some of these grid points may lie outside the window, if \code{window} is not of type \code{"rectangle"}. The function \code{\link{inside.owin}} can be used to select those grid points which do lie inside the window. See the examples. This function is useful in creating dummy points for quadrature schemes (see \code{\link{quadscheme}}) and for other miscellaneous purposes. } \seealso{ \code{\link{quad.object}}, \code{\link{quadscheme}}, \code{\link{inside.owin}}, \code{\link{stratrand}} } \examples{ w <- unit.square() xy <- gridcentres(w, 10,15) if(human <- interactive()) { plot(w) points(xy) } bdry <- list(x=c(0.1,0.3,0.7,0.4,0.2), y=c(0.1,0.1,0.5,0.7,0.3)) w <- owin(c(0,1), c(0,1), poly=bdry) xy <- gridcentres(w, 30, 30) ok <- inside.owin(xy$x, xy$y, w) if(human) { plot(w) points(xy$x[ok], xy$y[ok]) } } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/rescale.Rd0000644000176200001440000000501114611065350015521 0ustar liggesusers\name{rescale} \alias{rescale} \title{Convert dataset to another unit of length} \description{ Converts between different units of length in a spatial dataset, such as a point pattern or a window. } \usage{ rescale(X, s, unitname) } \arguments{ \item{X}{Any suitable dataset representing a two-dimensional object, such as a point pattern (object of class \code{"ppp"}), or a window (object of class \code{"owin"}).} \item{s}{Conversion factor: the new units are \code{s} times the old units.} \item{unitname}{ Optional. New name for the unit of length. See \code{\link{unitname}}. } } \value{ Another object of the same type, representing the same data, but expressed in the new units. } \details{ This is generic. Methods are provided for many spatial objects. The spatial coordinates in the dataset \code{X} will be re-expressed in terms of a new unit of length that is \code{s} times the current unit of length given in \code{X}. The name of the unit of length will also be adjusted. The result is an object of the same type, representing the same data, but expressed in the new units. For example if \code{X} is a dataset giving coordinates in metres, then \code{rescale(X,1000)} will take the new unit of length to be 1000 metres. To do this, it will divide the old coordinate values by 1000 to obtain coordinates expressed in kilometres, and change the name of the unit of length from \code{"metres"} to \code{"1000 metres"}. If \code{unitname} is given, it will be taken as the new name of the unit of length. It should be a valid name for the unit of length, as described in the help for \code{\link{unitname}}. For example if \code{X} is a dataset giving coordinates in metres, \code{rescale(X, 1000, "km")} will divide the coordinate values by 1000 to obtain coordinates in kilometres, and the unit name will be changed to \code{"km"}. } \section{Note}{ The result of this operation is equivalent to the original dataset. If you want to actually change the coordinates by a linear transformation, producing a dataset that is not equivalent to the original one, use \code{\link{affine}}. } \seealso{ Available methods: \code{\link{rescale.im}}, \code{\link{rescale.layered}}, \code{\link{rescale.owin}}, \code{\link{rescale.ppp}}, \code{\link{rescale.psp}} and \code{\link{rescale.unitname}}. Other generics: \code{\link{unitname}}, \code{\link{affine}}, \code{\link{rotate}}, \code{\link{shift}}. } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/marks.psp.Rd0000644000176200001440000000445114611065347016036 0ustar liggesusers\name{marks.psp} \alias{marks.psp} \alias{marks<-.psp} \title{Marks of a Line Segment Pattern} \description{ Extract or change the marks attached to a line segment pattern. } \usage{ \method{marks}{psp}(x, \dots, dfok=TRUE) \method{marks}{psp}(x, \dots) <- value } \arguments{ \item{x}{ Line segment pattern dataset (object of class \code{"psp"}). } \item{\dots}{ Ignored. } \item{dfok}{ Logical. If \code{FALSE}, data frames of marks are not permitted and will generate an error. } \item{value}{ Vector or data frame of mark values, or \code{NULL}. } } \value{ For \code{marks(x)}, the result is a vector, factor or data frame, containing the mark values attached to the line segments of \code{x}. If there are no marks, the result is \code{NULL}. For \code{marks(x) <- value}, the result is the updated line segment pattern \code{x} (with the side-effect that the dataset \code{x} is updated in the current environment). } \details{ These functions extract or change the marks attached to each of the line segments in the pattern \code{x}. They are methods for the generic functions \code{\link{marks}} and \code{\link{marks<-}} for the class \code{"psp"} of line segment patterns. The expression \code{marks(x)} extracts the marks of \code{x}. The assignment \code{marks(x) <- value} assigns new marks to the dataset \code{x}, and updates the dataset \code{x} in the current environment. The marks can be a vector, a factor, or a data frame. For the assignment \code{marks(x) <- value}, the \code{value} should be a vector or factor of length equal to the number of segments in \code{x}, or a data frame with as many rows as there are segments in \code{x}. If \code{value} is a single value, or a data frame with one row, then it will be replicated so that the same marks will be attached to each segment. To remove marks, use \code{marks(x) <- NULL} or \code{unmark(x)}. } \seealso{ \code{\link{psp.object}}, \code{\link{marks}}, \code{\link{marks<-}} } \examples{ m <- data.frame(A=1:10, B=letters[1:10]) X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin(), marks=m) marks(X) marks(X)[,2] marks(X) <- 42 marks(X) <- NULL } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/project2segment.Rd0000644000176200001440000000441614611065350017226 0ustar liggesusers\name{project2segment} \alias{project2segment} \title{Move Point To Nearest Line} \description{ Given a point pattern and a line segment pattern, this function moves each point to the closest location on a line segment. } \usage{ project2segment(X, Y) } \arguments{ \item{X}{A point pattern (object of class \code{"ppp"}).} \item{Y}{A line segment pattern (object of class \code{"psp"}).} } \details{ For each point \code{x} in the point pattern \code{X}, this function finds the closest line segment \code{y} in the line segment pattern \code{Y}. It then `projects' the point \code{x} onto the line segment \code{y} by finding the position \code{z} along \code{y} which is closest to \code{x}. This position \code{z} is returned, along with supplementary information. } \value{ A list with the following components. Each component has length equal to the number of points in \code{X}, and its entries correspond to the points of \code{X}. \item{Xproj }{ Point pattern (object of class \code{"ppp"} containing the projected points. } \item{mapXY }{ Integer vector identifying the nearest segment to each point. } \item{d}{ Numeric vector of distances from each point of \code{X} to the corresponding projected point. } \item{tp}{ Numeric vector giving the scaled parametric coordinate \eqn{0 \le t_p \le 1}{0 <= tp <= 1} of the position of the projected point along the segment. } For example suppose \code{mapXY[2] = 5} and \code{tp[2] = 0.33}. Then \code{Y[5]} is the line segment lying closest to \code{X[2]}. The projection of the point \code{X[2]} onto the segment \code{Y[5]} is the point \code{Xproj[2]}, which lies one-third of the way between the first and second endpoints of the line segment \code{Y[5]}. } \author{ \adrian and \rolf } \seealso{ \code{\link{nearestsegment}} for a faster way to determine which segment is closest to each point. } \examples{ X <- rsyst(square(1), nx=5) Y <- as.psp(matrix(runif(20), 5, 4), window=owin()) plot(Y, lwd=3, col="green") plot(X, add=TRUE, col="red", pch=16) v <- project2segment(X,Y) Xproj <- v$Xproj plot(Xproj, add=TRUE, pch=16) arrows(X$x, X$y, Xproj$x, Xproj$y, angle=10, length=0.15, col="red") } \keyword{spatial} \keyword{math} spatstat.geom/man/diameter.boxx.Rd0000644000176200001440000000346114611065346016670 0ustar liggesusers\name{diameter.boxx} \Rdversion{1.1} \alias{diameter.boxx} \alias{volume.boxx} \alias{shortside.boxx} \alias{sidelengths.boxx} \alias{eroded.volumes.boxx} \title{ Geometrical Calculations for Multi-Dimensional Box } \description{ Calculates the volume, diameter, shortest side, side lengths, or eroded volume of a multi-dimensional box. } \usage{ \method{diameter}{boxx}(x) \method{volume}{boxx}(x) \method{shortside}{boxx}(x) \method{sidelengths}{boxx}(x) \method{eroded.volumes}{boxx}(x, r) } \arguments{ \item{x}{ Multi-dimensional box (object of class \code{"boxx"}). } \item{r}{ Numeric value or vector of numeric values for which eroded volumes should be calculated. } } \details{ \code{diameter.boxx}, \code{volume.boxx} and \code{shortside.boxx} compute the diameter, volume and shortest side length of the box. \code{sidelengths.boxx} returns the lengths of each side of the box. \code{eroded.volumes.boxx} computes, for each entry \code{r[i]}, the volume of the smaller box obtained by removing a slab of thickness \code{r[i]} from each face of the box. This smaller box is the subset consisting of points that lie at least \code{r[i]} units away from the boundary of the box. } \value{ For \code{diameter.boxx}, \code{shortside.boxx} and \code{volume.boxx}, a single numeric value. For \code{sidelengths.boxx}, a numeric vector of length equal to the number of spatial dimensions. For \code{eroded.volumes.boxx}, a numeric vector of the same length as \code{r}. } \author{\adrian and \rolf } \seealso{ \code{\link{boxx}} } \examples{ X <- boxx(c(0,10),c(0,10),c(0,5),c(0,2)) diameter(X) volume(X) shortside(X) sidelengths(X) hd <- shortside(X)/2 eroded.volumes(X, seq(0,hd, length=10)) } \keyword{spatial} \keyword{math} spatstat.geom/man/quadratcount.Rd0000644000176200001440000001372714611065350016632 0ustar liggesusers\name{quadratcount} \alias{quadratcount} \alias{quadratcount.ppp} \alias{quadratcount.splitppp} \title{Quadrat counting for a point pattern} \description{ Divides window into quadrats and counts the numbers of points in each quadrat. } \usage{ quadratcount(X, \dots) \method{quadratcount}{ppp}(X, nx=5, ny=nx, \dots, xbreaks=NULL, ybreaks=NULL, tess=NULL) \method{quadratcount}{splitppp}(X, \dots) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"}) or a split point pattern (object of class \code{"splitppp"}). } \item{nx,ny}{ Numbers of rectangular quadrats in the \eqn{x} and \eqn{y} directions. Incompatible with \code{xbreaks} and \code{ybreaks}. } \item{\dots}{Additional arguments passed to \code{quadratcount.ppp}.} \item{xbreaks}{ Numeric vector giving the \eqn{x} coordinates of the boundaries of the rectangular quadrats. Incompatible with \code{nx}. } \item{ybreaks}{ Numeric vector giving the \eqn{y} coordinates of the boundaries of the rectangular quadrats. Incompatible with \code{ny}. } \item{tess}{ Tessellation (object of class \code{"tess"} or something acceptable to \code{\link{as.tess}}) determining the quadrats. Incompatible with \code{nx,ny,xbreaks,ybreaks}. } } \value{ The value of \code{quadratcount.ppp} is a contingency table containing the number of points in each quadrat. The table is also an object of the special class \code{"quadratcount"} and there is a plot method for this class. The value of \code{quadratcount.splitppp} is a list of such contingency tables, each containing the quadrat counts for one of the component point patterns in \code{X}. This list also has the class \code{"solist"} which has print and plot methods. } \details{ Quadrat counting is an elementary technique for analysing spatial point patterns. See Diggle (2003). \bold{If \code{X} is a point pattern}, then by default, the window containing the point pattern \code{X} is divided into an \code{nx * ny} grid of rectangular tiles or `quadrats'. (If the window is not a rectangle, then these tiles are intersected with the window.) The number of points of \code{X} falling in each quadrat is counted. These numbers are returned as a contingency table. If \code{xbreaks} is given, it should be a numeric vector giving the \eqn{x} coordinates of the quadrat boundaries. If it is not given, it defaults to a sequence of \code{nx+1} values equally spaced over the range of \eqn{x} coordinates in the window \code{Window(X)}. Similarly if \code{ybreaks} is given, it should be a numeric vector giving the \eqn{y} coordinates of the quadrat boundaries. It defaults to a vector of \code{ny+1} values equally spaced over the range of \eqn{y} coordinates in the window. The lengths of \code{xbreaks} and \code{ybreaks} may be different. Alternatively, quadrats of any shape may be used. The argument \code{tess} can be a tessellation (object of class \code{"tess"}) whose tiles will serve as the quadrats. The algorithm counts the number of points of \code{X} falling in each quadrat, and returns these counts as a contingency table. The return value is a \code{table} which can be printed neatly. The return value is also a member of the special class \code{"quadratcount"}. Plotting the object will display the quadrats, annotated by their counts. See the examples. To perform a chi-squared test based on the quadrat counts, use \code{\link[spatstat.explore]{quadrat.test}}. To calculate an estimate of intensity based on the quadrat counts, use \code{\link{intensity.quadratcount}}. To extract the quadrats used in a \code{quadratcount} object, use \code{\link{as.tess}}. \bold{If \code{X} is a split point pattern} (object of class \code{"splitppp"} then quadrat counting will be performed on each of the components point patterns, and the resulting contingency tables will be returned in a list. This list can be printed or plotted. Marks attached to the points are ignored by \code{quadratcount.ppp}. To obtain a separate contingency table for each type of point in a multitype point pattern, first separate the different points using \code{\link{split.ppp}}, then apply \code{quadratcount.splitppp}. See the Examples. } \note{ To perform a chi-squared test based on the quadrat counts, use \code{\link[spatstat.explore]{quadrat.test}}. } \section{Warning}{ If \code{Q} is a \code{quadratcount} object, the ordering of entries in the table \code{Q} \bold{may be different from} the ordering of quadrats (tiles in the tessellation \code{as.tess(Q)}). To obtain the entries of the table in the same order as the quadrats, use \code{counts <- as.numeric(t(Q))} or \code{counts <- marks(as.tess(Q))}. } \seealso{ \code{\link{plot.quadratcount}}, \code{\link{intensity.quadratcount}}, \code{\link{quadrats}}, \code{\link[spatstat.explore]{quadrat.test}}, \code{\link{tess}}, \code{\link{hextess}}, \code{\link[spatstat.random]{quadratresample}}, \code{\link[spatstat.explore]{miplot}} } \references{ Diggle, P.J. \emph{Statistical analysis of spatial point patterns}. Academic Press, 2003. Stoyan, D. and Stoyan, H. (1994) \emph{Fractals, random shapes and point fields: methods of geometrical statistics.} John Wiley and Sons. } \examples{ X <- runifrect(50) quadratcount(X) quadratcount(X, 4, 5) quadratcount(X, xbreaks=c(0, 0.3, 1), ybreaks=c(0, 0.4, 0.8, 1)) qX <- quadratcount(X, 4, 5) # plotting: plot(X, pch="+") plot(qX, add=TRUE, col="red", cex=1.5, lty=2) # irregular window plot(humberside) qH <- quadratcount(humberside, 2, 3) plot(qH, add=TRUE, col="blue", cex=1.5, lwd=2) # multitype - split plot(quadratcount(split(humberside), 2, 3)) # quadrats determined by tessellation: B <- dirichlet(runifrect(6)) qX <- quadratcount(X, tess=B) plot(X, pch="+") plot(qX, add=TRUE, col="red", cex=1.5, lty=2) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/levelset.Rd0000644000176200001440000000403214611065347015736 0ustar liggesusers\name{levelset} \alias{levelset} \title{Level Set of a Pixel Image} \description{ Given a pixel image, find all pixels which have values less than a specified threshold value (or greater than a threshold, etc), and assemble these pixels into a window. } \usage{ levelset(X, thresh, compare="<=") } \arguments{ \item{X}{A pixel image (object of class "im")}. \item{thresh}{Threshold value. A single number or value compatible with the pixel values in \code{X}}. \item{compare}{Character string specifying one of the comparison operators \code{"<", ">", "==", "<=", ">=", "!="}. } } \details{ If \code{X} is a pixel image with numeric values, then \code{levelset(X, thresh)} finds the region of space where the pixel values are less than or equal to the threshold value \code{thresh}. This region is returned as a spatial window. The argument \code{compare} specifies how the pixel values should be compared with the threshold value. Instead of requiring pixel values to be less than or equal to \code{thresh}, you can specify that they must be less than (\code{<}), greater than (\code{>}), equal to (\code{==}), greater than or equal to (\code{>=}), or not equal to (\code{!=}) the threshold value \code{thresh}. If \code{X} has non-numeric pixel values (for example, logical or factor values) it is advisable to use only the comparisons \code{==} and \code{!=}, unless you really know what you are doing. For more complicated logical comparisons, see \code{\link{solutionset}}. } \value{ A spatial window (object of class \code{"owin"}, see \code{\link{owin.object}}) containing the pixels satisfying the constraint. } \seealso{ \code{\link{im.object}}, \code{\link{as.owin}}, \code{\link{solutionset}}. } \examples{ # test image X <- as.im(function(x,y) { x^2 - y^2 }, unit.square()) W <- levelset(X, 0.2) W <- levelset(X, -0.3, ">") # compute area of level set area(levelset(X, 0.1)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{programming} \keyword{manip} spatstat.geom/man/bounding.box.xy.Rd0000644000176200001440000000243414611065345017150 0ustar liggesusers\name{bounding.box.xy} \alias{bounding.box.xy} \title{Convex Hull of Points} \description{ Computes the smallest rectangle containing a set of points. } \usage{ bounding.box.xy(x, y=NULL) } \arguments{ \item{x}{ vector of \code{x} coordinates of observed points, or a 2-column matrix giving \code{x,y} coordinates, or a list with components \code{x,y} giving coordinates (such as a point pattern object of class \code{"ppp"}.) } \item{y}{(optional) vector of \code{y} coordinates of observed points, if \code{x} is a vector.} } \value{ A window (an object of class \code{"owin"}). } \details{ Given an observed pattern of points with coordinates given by \code{x} and \code{y}, this function finds the smallest rectangle, with sides parallel to the coordinate axes, that contains all the points, and returns it as a window. } \seealso{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{convexhull.xy}}, \code{\link{ripras}} } \examples{ x <- runif(30) y <- runif(30) w <- bounding.box.xy(x,y) plot(owin(), main="bounding.box.xy(x,y)") plot(w, add=TRUE) points(x,y) X <- runifrect(30) plot(X, main="bounding.box.xy(X)") plot(bounding.box.xy(X), add=TRUE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{utilities} spatstat.geom/man/spatstat.geom-package.Rd0000644000176200001440000007762514765743246020332 0ustar liggesusers\name{spatstat.geom-package} \alias{spatstat.geom-package} \alias{spatstat.geom} \docType{package} \title{The spatstat.geom Package} \description{ The \pkg{spatstat.geom} package belongs to the \pkg{spatstat} family of packages. It defines classes of geometrical objects such as windows and point patterns, and provides functionality for geometrical operations on them. } \details{ \pkg{spatstat} is a family of \R packages for the statistical analysis of spatial data. Its main focus is the analysis of spatial patterns of points in two-dimensional space. The original \pkg{spatstat} package has now been split into several sub-packages. This sub-package \pkg{spatstat.geom} defines the main classes of geometrical objects (such as windows, point patterns, line segment patterns, pixel images) and supports geometrical operations (such as shifting and rotating, measuring areas and distances, finding nearest neighbours in a point pattern). Functions for performing statistical analysis and modelling are in the separate sub-packages \pkg{spatstat.explore} and \pkg{spatstat.model}. Functions for linear networks are in the separate sub-package \pkg{spatstat.linnet}. For an overview of all the functions available in the \pkg{spatstat} family, see the help file for \pkg{spatstat} in the \pkg{spatstat} package. } \section{Structure of the spatstat family}{ The original \pkg{spatstat} package grew to be very large, and CRAN requested that the package be divided into several \bold{sub-packages}. Currently the sub-packages are: \itemize{ \item \pkg{spatstat.utils} containing basic utilities \item \pkg{spatstat.data} containing datasets \item \pkg{spatstat.sparse} containing linear algebra utilities \item \pkg{spatstat.univar} containing functions for estimating probability distributions of random variables \item \pkg{spatstat.geom} containing geometrical objects and geometrical operations \item \pkg{spatstat.random} containing code for generating random spatial patterns \item \pkg{spatstat.explore} containing the main functionality for exploratory and non-parametric analysis of spatial data \item \pkg{spatstat.model} containing the main functionality for statistical modelling and inference for spatial data \item \pkg{spatstat.linnet} containing functions for spatial data on a linear network \item \pkg{spatstat}, which simply loads the other sub-packages listed above, and provides documentation. } When you install \pkg{spatstat}, these sub-packages are also installed. Then if you load the \pkg{spatstat} package by typing \code{library(spatstat)}, the other sub-packages listed above will automatically be loaded or imported. For an overview of all the functions available in these sub-packages, see the help file for \pkg{spatstat} in the \pkg{spatstat} package, Additionally there are several \bold{extension packages:} \itemize{ \item \pkg{spatstat.gui} for interactive graphics \item \pkg{spatstat.local} for local likelihood (including geographically weighted regression) \item \pkg{spatstat.Knet} for additional, computationally efficient code for linear networks \item \pkg{spatstat.sphere} (under development) for spatial data on a sphere, including spatial data on the earth's surface } The extension packages must be installed separately and loaded explicitly if needed. They also have separate documentation. } \section{OVERVIEW OF CAPABILITIES}{ Following is an overview of the capabilities of the \pkg{spatstat.geom} sub-package. \bold{Types of spatial data:} The main types of spatial data supported by \pkg{spatstat.geom} are: \tabular{ll}{ \code{\link{ppp}} \tab point pattern \cr \code{\link{owin}} \tab window (spatial region) \cr \code{\link{im}} \tab pixel image \cr \code{\link{psp}} \tab line segment pattern \cr \code{\link{tess}} \tab tessellation \cr \code{\link{pp3}} \tab three-dimensional point pattern \cr \code{\link{ppx}} \tab point pattern in any number of dimensions \cr } Additional data types are supported in \pkg{spatstat.linnet}. \bold{To create a point pattern:} \tabular{ll}{ \code{\link{ppp}} \tab create a point pattern from \eqn{(x,y)} and window information \cr \tab \code{ppp(x, y, xlim, ylim)} for rectangular window\cr \tab \code{ppp(x, y, poly)} for polygonal window \cr \tab \code{ppp(x, y, mask)} for binary image window \cr \code{\link{as.ppp}} \tab convert other types of data to a \code{ppp} object \cr \code{\link{clickppp}} \tab interactively add points to a plot \cr \code{\link{marks<-}}, \code{\%mark\%} \tab attach/reassign marks to a point pattern } \bold{To simulate a random point pattern:} Most of the methods for generating random data are provided in \pkg{spatstat.random}. The following basic methods are supplied in \pkg{spatstat.geom}: \tabular{ll}{ \code{\link{runifrect}} \tab generate \eqn{n} independent uniform random points in a rectangle \cr \code{\link{rsyst}} \tab systematic random sample of points \cr \code{\link{rjitter}} \tab apply random displacements to points in a pattern\cr } \bold{Standard point pattern datasets:} Datasets installed in the \pkg{spatstat} family are provided in the sub-package \code{spatstat.data}. \bold{To manipulate a point pattern:} \tabular{ll}{ \code{\link{plot.ppp}} \tab plot a point pattern (e.g. \code{plot(X)}) \cr \code{spatstat.gui::iplot} \tab plot a point pattern interactively \cr \code{\link{persp.ppp}} \tab perspective plot of marked point pattern \cr \code{\link{edit.ppp}} \tab interactive text editor \cr \code{\link{[.ppp}} \tab extract or replace a subset of a point pattern \cr \tab \code{pp[subset]} or \code{pp[subwindow]} \cr \code{\link{subset.ppp}} \tab extract subset of point pattern satisfying a condition \cr \code{\link{superimpose}} \tab combine several point patterns \cr \code{\link{by.ppp}} \tab apply a function to sub-patterns of a point pattern \cr \code{\link{cut.ppp}} \tab classify the points in a point pattern \cr \code{\link{split.ppp}} \tab divide pattern into sub-patterns \cr \code{\link{unmark}} \tab remove marks \cr \code{\link{npoints}} \tab count the number of points \cr \code{\link{coords}} \tab extract coordinates, change coordinates \cr \code{\link{marks}} \tab extract marks, change marks or attach marks \cr \code{\link{rotate}} \tab rotate pattern \cr \code{\link{shift} } \tab translate pattern \cr \code{\link{flipxy} } \tab swap \eqn{x} and \eqn{y} coordinates \cr \code{\link{reflect} } \tab reflect in the origin \cr \code{\link{periodify} } \tab make several translated copies \cr \code{\link{affine}} \tab apply affine transformation\cr \code{\link{scalardilate}} \tab apply scalar dilation\cr \code{\link{nnmark}} \tab mark value of nearest data point\cr \code{\link{identify.ppp}} \tab interactively identify points \cr \code{\link{unique.ppp}} \tab remove duplicate points \cr \code{\link{duplicated.ppp}} \tab determine which points are duplicates \cr \code{\link{uniquemap.ppp}} \tab map duplicated points to unique points \cr \code{\link{connected.ppp}} \tab find clumps of points \cr \code{\link{dirichlet}} \tab compute Dirichlet-Voronoi tessellation \cr \code{\link{delaunay}} \tab compute Delaunay triangulation \cr \code{\link{delaunayDistance}} \tab graph distance in Delaunay triangulation \cr \code{\link{convexhull}} \tab compute convex hull \cr \code{\link{discretise}} \tab discretise coordinates \cr \code{\link{pixellate.ppp}} \tab approximate point pattern by pixel image \cr \code{\link{as.im.ppp}} \tab approximate point pattern by pixel image } See \code{\link{spatstat.options}} to control plotting behaviour. \bold{To create a window:} An object of class \code{"owin"} describes a spatial region (a window of observation). \tabular{ll}{ \code{\link{owin}} \tab Create a window object \cr \tab \code{owin(xlim, ylim)} for rectangular window \cr \tab \code{owin(poly)} for polygonal window \cr \tab \code{owin(mask)} for binary image window \cr \code{\link{Window}} \tab Extract window of another object \cr \code{\link{Frame}} \tab Extract the containing rectangle ('frame') of another object \cr \code{\link{as.owin}} \tab Convert other data to a window object \cr \code{\link{square}} \tab make a square window \cr \code{\link{disc}} \tab make a circular window \cr \code{\link{ellipse}} \tab make an elliptical window \cr \code{\link{ripras}} \tab Ripley-Rasson estimator of window, given only the points \cr \code{\link{convexhull}} \tab compute convex hull of something \cr \code{\link[spatstat.data]{letterR}} \tab polygonal window in the shape of the \R logo \cr \code{\link{clickpoly}} \tab interactively draw a polygonal window \cr \code{\link{clickbox}} \tab interactively draw a rectangle } \bold{To manipulate a window:} \tabular{ll}{ \code{\link{plot.owin}} \tab plot a window. \cr \tab \code{plot(W)}\cr \code{\link{boundingbox}} \tab Find a tight bounding box for the window \cr \code{\link{erosion}} \tab erode window by a distance r\cr \code{\link{dilation}} \tab dilate window by a distance r\cr \code{\link{closing}} \tab close window by a distance r\cr \code{\link{opening}} \tab open window by a distance r\cr \code{\link{border}} \tab difference between window and its erosion/dilation \cr \code{\link{complement.owin}} \tab invert (swap inside and outside)\cr \code{\link{simplify.owin}} \tab approximate a window by a simple polygon \cr \code{\link{rotate}} \tab rotate window \cr \code{\link{flipxy}} \tab swap \eqn{x} and \eqn{y} coordinates \cr \code{\link{shift} } \tab translate window \cr \code{\link{periodify} } \tab make several translated copies \cr \code{\link{affine}} \tab apply affine transformation \cr \code{\link{as.data.frame.owin}} \tab convert window to data frame } \bold{Digital approximations:} \tabular{ll}{ \code{\link[spatstat.geom]{as.mask}} \tab Make a discrete pixel approximation of a given window \cr \code{\link{as.im.owin}} \tab convert window to pixel image \cr \code{\link{pixellate.owin}} \tab convert window to pixel image \cr \code{\link{commonGrid}} \tab find common pixel grid for windows \cr \code{\link{nearest.raster.point}} \tab map continuous coordinates to raster locations\cr \code{\link{raster.x}} \tab raster x coordinates \cr \code{\link{raster.y}} \tab raster y coordinates \cr \code{\link{raster.xy}} \tab raster x and y coordinates \cr \code{\link{as.polygonal}} \tab convert pixel mask to polygonal window } See \code{\link{spatstat.options}} to control the approximation \bold{Geometrical computations with windows:} \tabular{ll}{ \code{\link{edges}} \tab extract boundary edges \cr \code{\link{intersect.owin}} \tab intersection of two windows\cr \code{\link{union.owin}} \tab union of two windows\cr \code{\link{setminus.owin}} \tab set subtraction of two windows\cr \code{\link{inside.owin}} \tab determine whether a point is inside a window\cr \code{\link{area.owin}} \tab compute area \cr \code{\link{perimeter}} \tab compute perimeter length \cr \code{\link{diameter.owin}} \tab compute diameter\cr \code{\link{incircle}} \tab find largest circle inside a window \cr \code{\link{inradius}} \tab radius of incircle \cr \code{\link{connected.owin}} \tab find connected components of window \cr \code{\link{eroded.areas}} \tab compute areas of eroded windows\cr \code{\link{dilated.areas}} \tab compute areas of dilated windows\cr \code{\link{bdist.points}} \tab compute distances from data points to window boundary \cr \code{\link{bdist.pixels}} \tab compute distances from all pixels to window boundary \cr \code{\link{bdist.tiles}} \tab boundary distance for each tile in tessellation \cr \code{\link{distmap.owin}} \tab distance transform image \cr \code{\link{distfun.owin}} \tab distance transform \cr \code{\link{centroid.owin}} \tab compute centroid (centre of mass) of window\cr \code{\link{is.subset.owin}} \tab determine whether one window contains another \cr \code{\link{is.convex}} \tab determine whether a window is convex \cr \code{\link{convexhull}} \tab compute convex hull \cr \code{\link{triangulate.owin}} \tab decompose into triangles \cr \code{\link[spatstat.geom]{as.mask}} \tab pixel approximation of window \cr \code{\link{as.polygonal}} \tab polygonal approximation of window \cr \code{\link{is.rectangle}} \tab test whether window is a rectangle \cr \code{\link{is.polygonal}} \tab test whether window is polygonal \cr \code{\link{is.mask}} \tab test whether window is a mask \cr \code{\link{setcov}} \tab spatial covariance function of window \cr \code{\link{pixelcentres}} \tab extract centres of pixels in mask \cr \code{\link{clickdist}} \tab measure distance between two points clicked by user } \bold{Pixel images:} An object of class \code{"im"} represents a pixel image. Such objects are returned by some of the functions in \pkg{spatstat} including \code{\link[spatstat.explore]{Kmeasure}}, \code{\link{setcov}} and \code{\link[spatstat.explore]{density.ppp}}. \tabular{ll}{ \code{\link{im}} \tab create a pixel image\cr \code{\link{as.im}} \tab convert other data to a pixel image\cr \code{\link{pixellate}} \tab convert other data to a pixel image\cr \code{\link{as.matrix.im}} \tab convert pixel image to matrix\cr \code{\link{as.data.frame.im}} \tab convert pixel image to data frame\cr \code{\link{as.function.im}} \tab convert pixel image to function\cr \code{\link{plot.im}} \tab plot a pixel image on screen as a digital image\cr \code{\link{contour.im}} \tab draw contours of a pixel image \cr \code{\link{persp.im}} \tab draw perspective plot of a pixel image \cr \code{\link{rgbim}} \tab create colour-valued pixel image \cr \code{\link{hsvim}} \tab create colour-valued pixel image \cr \code{\link{[.im}} \tab extract a subset of a pixel image\cr \code{\link{[<-.im}} \tab replace a subset of a pixel image\cr \code{\link{rotate.im}} \tab rotate pixel image \cr \code{\link{shift.im}} \tab apply vector shift to pixel image \cr \code{\link{affine.im}} \tab apply affine transformation to image \cr \code{X} \tab print very basic information about image \code{X}\cr \code{\link{summary}(X)} \tab summary of image \code{X} \cr \code{\link{hist.im}} \tab histogram of image \cr \code{\link{mean.im}} \tab mean pixel value of image \cr \code{\link{integral.im}} \tab integral of pixel values \cr \code{\link{quantile.im}} \tab quantiles of image \cr \code{\link{cut.im}} \tab convert numeric image to factor image \cr \code{\link{is.im}} \tab test whether an object is a pixel image\cr \code{\link{interp.im}} \tab interpolate a pixel image\cr \code{\link{connected.im}} \tab find connected components \cr \code{\link{compatible.im}} \tab test whether two images have compatible dimensions \cr \code{\link{harmonise.im}} \tab make images compatible \cr \code{\link{commonGrid}} \tab find a common pixel grid for images \cr \code{\link{eval.im}} \tab evaluate any expression involving images\cr \code{\link{im.apply}} \tab evaluate a function of several images \cr \code{\link{scaletointerval}} \tab rescale pixel values \cr \code{\link{zapsmall.im}} \tab set very small pixel values to zero \cr \code{\link{levelset}} \tab level set of an image\cr \code{\link{solutionset}} \tab region where an expression is true \cr \code{\link{imcov}} \tab spatial covariance function of image \cr \code{\link{convolve.im}} \tab spatial convolution of images \cr \code{\link{pixelcentres}} \tab extract centres of pixels \cr \code{\link{transmat}} \tab convert matrix of pixel values \cr \tab to a different indexing convention } \bold{Line segment patterns} An object of class \code{"psp"} represents a pattern of straight line segments. \tabular{ll}{ \code{\link{psp}} \tab create a line segment pattern \cr \code{\link{as.psp}} \tab convert other data into a line segment pattern \cr \code{\link{edges}} \tab extract edges of a window \cr \code{\link{is.psp}} \tab determine whether a dataset has class \code{"psp"} \cr \code{\link{plot.psp}} \tab plot a line segment pattern \cr \code{\link{print.psp}} \tab print basic information \cr \code{\link{summary.psp}} \tab print summary information \cr \code{\link{[.psp}} \tab extract a subset of a line segment pattern \cr \code{\link{subset.psp}} \tab extract subset of line segment pattern \cr \code{\link{as.data.frame.psp}} \tab convert line segment pattern to data frame \cr \code{\link{marks.psp}} \tab extract marks of line segments \cr \code{\link{marks<-.psp}} \tab assign new marks to line segments \cr \code{\link{unmark.psp}} \tab delete marks from line segments \cr \code{\link{midpoints.psp}} \tab compute the midpoints of line segments \cr \code{\link{endpoints.psp}} \tab extract the endpoints of line segments \cr \code{\link{lengths_psp}} \tab compute the lengths of line segments \cr \code{\link{angles.psp}} \tab compute the orientation angles of line segments \cr \code{\link{superimpose}} \tab combine several line segment patterns \cr \code{\link{flipxy}} \tab swap \eqn{x} and \eqn{y} coordinates \cr \code{\link{rotate.psp}} \tab rotate a line segment pattern \cr \code{\link{shift.psp}} \tab shift a line segment pattern \cr \code{\link{periodify}} \tab make several shifted copies \cr \code{\link{affine.psp}} \tab apply an affine transformation \cr \code{\link{pixellate.psp}} \tab approximate line segment pattern by pixel image \cr \code{\link{as.mask.psp}} \tab approximate line segment pattern by binary mask \cr \code{\link{distmap.psp}} \tab compute the distance map of a line segment pattern \cr \code{\link{distfun.psp}} \tab compute the distance map of a line segment pattern \cr \code{\link{selfcrossing.psp}} \tab find crossing points between line segments \cr \code{\link{selfcut.psp}} \tab cut segments where they cross \cr \code{\link{crossing.psp}} \tab find crossing points between two line segment patterns \cr \code{\link{extrapolate.psp}} \tab extrapolate line segments to infinite lines \cr \code{\link{nncross}} \tab find distance to nearest line segment from a given point\cr \code{\link{nearestsegment}} \tab find line segment closest to a given point \cr \code{\link{project2segment}} \tab find location along a line segment closest to a given point \cr \code{\link{pointsOnLines}} \tab generate points evenly spaced along line segment \cr \code{\link{rlinegrid}} \tab generate a random array of parallel lines through a window } \bold{Tessellations} An object of class \code{"tess"} represents a tessellation. \tabular{ll}{ \code{\link{tess}} \tab create a tessellation \cr \code{\link{quadrats}} \tab create a tessellation of rectangles\cr \code{\link{hextess}} \tab create a tessellation of hexagons \cr \code{\link{polartess}} \tab tessellation using polar coordinates \cr \code{\link{quantess}} \tab quantile tessellation \cr \code{\link{venn.tess}} \tab Venn diagram tessellation \cr \code{\link{dirichlet}} \tab compute Dirichlet-Voronoi tessellation of points\cr \code{\link{delaunay}} \tab compute Delaunay triangulation of points\cr \code{\link{as.tess}} \tab convert other data to a tessellation \cr \code{\link{plot.tess}} \tab plot a tessellation \cr \code{\link{tiles}} \tab extract all the tiles of a tessellation \cr \code{\link{[.tess}} \tab extract some tiles of a tessellation \cr \code{\link{[<-.tess}} \tab change some tiles of a tessellation \cr \code{\link{intersect.tess}} \tab intersect two tessellations \cr \tab or restrict a tessellation to a window \cr \code{\link{chop.tess}} \tab subdivide a tessellation by a line \cr \code{\link{tile.areas}} \tab area of each tile in tessellation \cr \code{\link{bdist.tiles}} \tab boundary distance for each tile in tessellation \cr \code{\link{connected.tess}} \tab find connected components of tiles \cr \code{\link{shift.tess}} \tab shift a tessellation \cr \code{\link{rotate.tess}} \tab rotate a tessellation \cr \code{\link{reflect.tess}} \tab reflect about the origin \cr \code{\link{flipxy.tess}} \tab reflect about the diagonal \cr \code{\link{affine.tess}} \tab apply affine transformation } Functions which are constant on each tile of a tessellation: \tabular{ll}{ \code{\link{as.function.tess}} \tab convert tessellation to function\cr \code{\link{plot.tessfun}} \tab plot the function \cr \code{\link{integral.tessfun}} \tab integrate the function \cr \code{\link{as.tess.tessfun}} \tab retrieve the original tessellation } \bold{Three-dimensional point patterns} An object of class \code{"pp3"} represents a three-dimensional point pattern in a rectangular box. The box is represented by an object of class \code{"box3"}. \tabular{ll}{ \code{\link{pp3}} \tab create a 3-D point pattern \cr \code{\link{plot.pp3}} \tab plot a 3-D point pattern \cr \code{\link{coords}} \tab extract coordinates \cr \code{\link{as.hyperframe}} \tab extract coordinates \cr \code{\link{subset.pp3}} \tab extract subset of 3-D point pattern \cr \code{\link{unitname.pp3}} \tab name of unit of length \cr \code{\link{npoints}} \tab count the number of points \cr \code{\link{box3}} \tab create a 3-D rectangular box \cr \code{\link{as.box3}} \tab convert data to 3-D rectangular box \cr \code{\link{unitname.box3}} \tab name of unit of length \cr \code{\link{diameter.box3}} \tab diameter of box \cr \code{\link{volume.box3}} \tab volume of box \cr \code{\link{shortside.box3}} \tab shortest side of box \cr \code{\link{eroded.volumes}} \tab volumes of erosions of box } \bold{Multi-dimensional space-time point patterns} An object of class \code{"ppx"} represents a point pattern in multi-dimensional space and/or time. \tabular{ll}{ \code{\link{ppx}} \tab create a multidimensional space-time point pattern \cr \code{\link{coords}} \tab extract coordinates \cr \code{\link{as.hyperframe}} \tab extract coordinates \cr \code{\link{subset.ppx}} \tab extract subset \cr \code{\link{unitname.ppx}} \tab name of unit of length \cr \code{\link{npoints}} \tab count the number of points \cr \code{\link{boxx}} \tab define multidimensional box \cr \code{\link{diameter.boxx}} \tab diameter of box \cr \code{\link{volume.boxx}} \tab volume of box \cr \code{\link{shortside.boxx}} \tab shortest side of box \cr \code{\link{eroded.volumes.boxx}} \tab volumes of erosions of box } \bold{Linear networks} An object of class \code{"linnet"} represents a linear network (for example, a road network). This is supported in the sub-package \pkg{spatstat.linnet}. An object of class \code{"lpp"} represents a point pattern on a linear network (for example, road accidents on a road network). \bold{Hyperframes} A hyperframe is like a data frame, except that the entries may be objects of any kind. \tabular{ll}{ \code{\link{hyperframe}} \tab create a hyperframe \cr \code{\link{as.hyperframe}} \tab convert data to hyperframe \cr \code{\link{plot.hyperframe}} \tab plot hyperframe \cr \code{\link{with.hyperframe}} \tab evaluate expression using each row of hyperframe \cr \code{\link{cbind.hyperframe}} \tab combine hyperframes by columns\cr \code{\link{rbind.hyperframe}} \tab combine hyperframes by rows\cr \code{\link{as.data.frame.hyperframe}} \tab convert hyperframe to data frame \cr \code{\link{subset.hyperframe}} \tab method for \code{subset} \cr \code{\link{head.hyperframe}} \tab first few rows of hyperframe \cr \code{\link{tail.hyperframe}} \tab last few rows of hyperframe } \bold{Layered objects} A layered object represents data that should be plotted in successive layers, for example, a background and a foreground. \tabular{ll}{ \code{\link{layered}} \tab create layered object \cr \code{\link{plot.layered}} \tab plot layered object\cr \code{\link{[.layered}} \tab extract subset of layered object } \bold{Colour maps} A colour map is a mechanism for associating colours with data. It can be regarded as a function, mapping data to colours. Using a \code{colourmap} object in a plot command ensures that the mapping from numbers to colours is the same in different plots. \tabular{ll}{ \code{\link{colourmap}} \tab create a colour map \cr \code{\link{plot.colourmap}} \tab plot the colour map only\cr \code{\link{tweak.colourmap}} \tab alter individual colour values \cr \code{\link{interp.colourmap}} \tab make a smooth transition between colours \cr \code{\link{beachcolourmap}} \tab one special colour map } \bold{Inspection of data:} \tabular{ll}{ \code{\link{summary}(X)} \tab print useful summary of point pattern \code{X}\cr \code{X} \tab print basic description of point pattern \code{X} \cr \code{any(duplicated(X))} \tab check for duplicated points in pattern \code{X} \cr \code{\link{intensity}} \tab Mean intensity \cr \code{\link{quadratcount}} \tab Quadrat counts \cr } \bold{Distances in a point pattern:} \tabular{ll}{ \code{\link{nndist}} \tab nearest neighbour distances \cr \code{\link{nnwhich}} \tab find nearest neighbours \cr \code{\link{pairdist}} \tab distances between all pairs of points\cr \code{\link{crossdist}} \tab distances between points in two patterns\cr \code{\link{nncross}} \tab nearest neighbours between two point patterns \cr \code{\link{exactdt}} \tab distance from any location to nearest data point\cr \code{\link{distmap}} \tab distance map image\cr \code{\link{distfun}} \tab distance map function\cr \code{\link{nnmap}} \tab nearest point image \cr \code{\link{nnfun}} \tab nearest point function } \bold{Programming tools:} \tabular{ll}{ \code{\link{applynbd}} \tab apply function to every neighbourhood in a point pattern \cr \code{\link{markstat}} \tab apply function to the marks of neighbours in a point pattern \cr \code{\link{pppdist}} \tab find the optimal match between two point patterns } \bold{Distances in a three-dimensional point pattern:} \tabular{ll}{ \code{\link{pairdist.pp3}} \tab distances between all pairs of points \cr \code{\link{crossdist.pp3}} \tab distances between points in two patterns \cr \code{\link{nndist.pp3}} \tab nearest neighbour distances \cr \code{\link{nnwhich.pp3}} \tab find nearest neighbours \cr \code{\link{nncross.pp3}} \tab find nearest neighbours in another pattern } \bold{Distances in multi-dimensional point pattern:} These are for multi-dimensional space-time point pattern objects (class \code{ppx}). \tabular{ll}{ \code{\link{pairdist.ppx}} \tab distances between all pairs of points \cr \code{\link{crossdist.ppx}} \tab distances between points in two patterns \cr \code{\link{nndist.ppx}} \tab nearest neighbour distances \cr \code{\link{nnwhich.ppx}} \tab find nearest neighbours } } \section{Licence}{ This library and its documentation are usable under the terms of the "GNU General Public License", a copy of which is distributed with the package. } \author{ \spatstatAuthors. } \section{Acknowledgements}{ Kasper Klitgaard Berthelsen, Ottmar Cronie, Tilman Davies, Yongtao Guan, Ute Hahn, Abdollah Jalilian, Marie-Colette van Lieshout, Greg McSwiggan, Tuomas Rajala, Suman Rakshit, Dominic Schuhmacher, Rasmus Waagepetersen and Hangsheng Wang made substantial contributions of code. Additional contributions and suggestions from Monsuru Adepeju, Corey Anderson, Ang Qi Wei, Ryan Arellano, Jens \ifelse{latex}{\out{{\AA}str{\" o}m}}{Astrom}, Robert Aue, Marcel Austenfeld, Sandro Azaele, Malissa Baddeley, Guy Bayegnak, Colin Beale, Melanie Bell, Thomas Bendtsen, Ricardo Bernhardt, Andrew Bevan, Brad Biggerstaff, Anders Bilgrau, Leanne Bischof, Christophe Biscio, Roger Bivand, Jose M. Blanco Moreno, Florent Bonneu, Jordan Brown, Ian Buller, Julian Burgos, Simon Byers, Ya-Mei Chang, Jianbao Chen, Igor Chernayavsky, Y.C. Chin, Bjarke Christensen, \ifelse{latex}{\out{Luc\'{\i{}}a}}{Lucia} Cobo Sanchez, Jean-Francois Coeurjolly, Kim Colyvas, Hadrien Commenges, Rochelle Constantine, Robin Corria Ainslie, Richard Cotton, Marcelino de la Cruz, Peter Dalgaard, Mario D'Antuono, Sourav Das, Peter Diggle, Patrick Donnelly, Ian Dryden, Stephen Eglen, Ahmed El-Gabbas, Belarmain Fandohan, Olivier Flores, David Ford, Peter Forbes, Shane Frank, Janet Franklin, Funwi-Gabga Neba, Oscar Garcia, Agnes Gault, Jonas Geldmann, Marc Genton, Shaaban Ghalandarayeshi, Julian Gilbey, Jason Goldstick, Pavel Grabarnik, C. Graf, Ute Hahn, Andrew Hardegen, Martin \Bogsted Hansen, Martin Hazelton, Juha Heikkinen, Mandy Hering, Markus Herrmann, Maximilian Hesselbarth, Paul Hewson, Hamidreza Heydarian, Kassel Hingee, Kurt Hornik, Philipp Hunziker, Jack Hywood, Ross Ihaka, \ifelse{latex}{\out{\u{C}enk I\c{c}\"{o}s}}{Cenk Icos}, Aruna Jammalamadaka, Robert John-Chandran, Devin Johnson, Mahdieh Khanmohammadi, Bob Klaver, Lily Kozmian-Ledward, Peter Kovesi, Mike Kuhn, Jeff Laake, Robert Lamb, \ifelse{latex}{\out{Fr\'{e}d\'{e}ric}}{Frederic} Lavancier, Tom Lawrence, Tomas Lazauskas, Jonathan Lee, George Leser, Angela Li, Li Haitao, George Limitsios, Andrew Lister, Nestor Luambua, Ben Madin, Martin Maechler, Kiran Marchikanti, Jeff Marcus, Robert Mark, Peter McCullagh, Monia Mahling, Jorge Mateu Mahiques, Ulf Mehlig, Frederico Mestre, Sebastian Wastl Meyer, Mi Xiangcheng, Lore De Middeleer, Robin Milne, Enrique Miranda, Jesper \Moller, Annie \ifelse{latex}{\out{Molli{\'e}}}{Mollie}, Ines Moncada, Mehdi Moradi, Virginia Morera Pujol, Erika Mudrak, Gopalan Nair, Nader Najari, Nicoletta Nava, Linda Stougaard Nielsen, Felipe Nunes, Jens Randel Nyengaard, Jens \Oehlschlaegel, Thierry Onkelinx, Sean O'Riordan, Evgeni Parilov, Jeff Picka, Nicolas Picard, Tim Pollington, Mike Porter, Sergiy Protsiv, Adrian Raftery, Suman Rakshit, Ben Ramage, Pablo Ramon, Xavier Raynaud, Nicholas Read, Matt Reiter, Ian Renner, Tom Richardson, Brian Ripley, Ted Rosenbaum, Barry Rowlingson, Jason Rudokas, Tyler Rudolph, John Rudge, Christopher Ryan, Farzaneh Safavimanesh, Aila \Sarkka, Cody Schank, Katja Schladitz, Sebastian Schutte, Bryan Scott, Olivia Semboli, \ifelse{latex}{\out{Fran\c{c}ois S\'{e}m\'{e}curbe}}{Francois Semecurbe}, Vadim Shcherbakov, Shen Guochun, Shi Peijian, Harold-Jeffrey Ship, Tammy L Silva, Ida-Maria Sintorn, Yong Song, Malte Spiess, Mark Stevenson, Kaspar Stucki, Jan Sulavik, Michael Sumner, P. Surovy, Ben Taylor, Thordis Linda Thorarinsdottir, Leigh Torres, Berwin Turlach, Torben Tvedebrink, Kevin Ummer, Medha Uppala, Andrew van Burgel, Tobias Verbeke, Mikko Vihtakari, Alexendre Villers, Fabrice Vinatier, Maximilian Vogtland, Sasha Voss, Sven Wagner, Hao Wang, H. Wendrock, Jan Wild, Carl G. Witthoft, Selene Wong, Maxime Woringer, Luke Yates, Mike Zamboni and Achim Zeileis. } \keyword{spatial} \keyword{package} spatstat.geom/man/quadscheme.logi.Rd0000644000176200001440000001235614611065350017165 0ustar liggesusers\name{quadscheme.logi} \alias{quadscheme.logi} \title{Generate a Logistic Regression Quadrature Scheme from a Point Pattern} \description{ Generates a logistic regression quadrature scheme (an object of class \code{"logiquad"} inheriting from \code{"quad"}) from point patterns of data and dummy points. } \usage{ quadscheme.logi(data, dummy, dummytype = "stratrand", nd = NULL, mark.repeat = FALSE, \dots) } \arguments{ \item{data}{ The observed data point pattern. An object of class \code{"ppp"} or in a format recognised by \code{\link{as.ppp}()} } \item{dummy}{ The pattern of dummy points for the quadrature. An object of class \code{"ppp"} or in a format recognised by \code{\link{as.ppp}()}. If missing a sensible default is generated. } \item{dummytype}{ The name of the type of dummy points to use when \code{"dummy"} is missing. Currently available options are: \code{"stratrand"} (default), \code{"binomial"}, \code{"poisson"}, \code{"grid"} and \code{"transgrid"}. } \item{nd}{ Integer, or integer vector of length 2 controlling the intensity of dummy points when \code{"dummy"} is missing. } \item{mark.repeat}{ Repeating the dummy points for each level of a marked data pattern when \code{"dummy"} is missing. (See details.) } \item{\dots}{ Ignored. } } \value{ An object of class \code{"logiquad"} inheriting from \code{"quad"} describing the quadrature scheme (data points, dummy points, and quadrature weights) suitable as the argument \code{Q} of the function \code{\link[spatstat.model]{ppm}()} for fitting a point process model. The quadrature scheme can be inspected using the \code{print} and \code{plot} methods for objects of class \code{"quad"}. } \details{ This is the primary method for producing a quadrature schemes for use by \code{\link[spatstat.model]{ppm}} when the logistic regression approximation (Baddeley et al. 2013) to the pseudolikelihood of the model is applied (i.e. when \code{method="logi"} in \code{\link[spatstat.model]{ppm}}). The function \code{\link[spatstat.model]{ppm}} fits a point process model to an observed point pattern. When used with the option \code{method="logi"} it requires a quadrature scheme consisting of the original data point pattern and an additional pattern of dummy points. Such quadrature schemes are represented by objects of class \code{"logiquad"}. Quadrature schemes are created by the function \code{quadscheme.logi}. The arguments \code{data} and \code{dummy} specify the data and dummy points, respectively. There is a sensible default for the dummy points. Alternatively the dummy points may be specified arbitrarily and given in any format recognised by \code{\link{as.ppp}}. The quadrature region is the region over which we are integrating, and approximating integrals by finite sums. If \code{dummy} is a point pattern object (class \code{"ppp"}) then the quadrature region is taken to be \code{Window(dummy)}. If \code{dummy} is just a list of \eqn{x, y} coordinates then the quadrature region defaults to the observation window of the data pattern, \code{Window(data)}. If \code{dummy} is missing, then a pattern of dummy points will be generated, taking account of the optional arguments \code{dummytype}, \code{nd}, and \code{mark.repeat}. The currently accepted values for \code{dummytype} are: \itemize{ \item \code{"grid"} where the frame of the window is divided into a \code{nd * nd} or \code{nd[1] * nd[2]} regular grid of tiles and the centers constitutes the dummy points. \item \code{"transgrid"} where a regular grid as above is translated by a random vector. \item \code{"stratrand"} where each point of a regular grid as above is randomly translated within its tile. \item \code{"binomial"} where \code{nd * nd} or \code{nd[1] * nd[2]} points are generated uniformly in the frame of the window. \code{"poisson"} where a homogeneous Poisson point process with intensity \code{nd * nd} or \code{nd[1] * nd[2]} is generated within the frame of observation window. } Then if the window is not rectangular, any dummy points lying outside it are deleted. If \code{data} is a multitype point pattern the dummy points should also be marked (with the same levels of the marks as \code{data}). If \code{dummy} is missing and the dummy pattern is generated by \code{quadscheme.logi} the default behaviour is to attach a uniformly distributed mark (from the levels of the marks) to each dummy point. Alternatively, if \code{mark.repeat=TRUE} each dummy point is repeated as many times as there are levels of the marks with a distinct mark value attached to it. Finally, each point (data and dummy) is assigned the weight 1. The weights are never used and only appear to be compatible with the class \code{"quad"} from which the \code{"logiquad"} object inherits. } \references{ Baddeley, A., Coeurjolly, J.-F., Rubak, E. and Waagepetersen, R. (2014) Logistic regression for spatial Gibbs point processes. \emph{Biometrika} \bold{101} (2) 377--392. } \seealso{ \code{\link[spatstat.model]{ppm}}, \code{\link{as.ppp}} } \examples{ Q <- quadscheme.logi(simdat) } \author{\spatstatAuthors.} \keyword{spatial} \keyword{datagen} spatstat.geom/man/intersect.boxx.Rd0000644000176200001440000000150014611065346017066 0ustar liggesusers\name{intersect.boxx} \alias{intersect.boxx} \title{Intersection Of Boxes Of Arbitrary Dimension} \description{ Yields the intersection of boxes of arbitrary dimension (of class \code{"boxx"}). } \usage{ intersect.boxx(\dots, fatal=FALSE) } \arguments{ \item{\dots}{ Boxes (of class \code{"boxx"}). } \item{fatal}{Logical. Determines what happens if the intersection is empty: If true } } \value{ A box (object of class \code{"boxx"}) or possibly \code{NULL}. } \details{ If the intersection is empty, then if \code{fatal=FALSE} the result is \code{NULL}, while if \code{fatal=TRUE} an error occurs. } \author{ \spatstatAuthors. } \seealso{ \code{\link{intersect.owin}}, \code{\link{boxx}} } \examples{ intersect.boxx(boxx(c(-1,1),c(0,2)), boxx(c(0,3),c(0,1))) } \keyword{spatial} \keyword{math} spatstat.geom/man/rotate.ppp.Rd0000644000176200001440000000234614611065350016207 0ustar liggesusers\name{rotate.ppp} \alias{rotate.ppp} \title{Rotate a Point Pattern} \description{ Rotates a point pattern } \usage{ \method{rotate}{ppp}(X, angle=pi/2, \dots, centre=NULL) } \arguments{ \item{X}{A point pattern (object of class \code{"ppp"}).} \item{angle}{Angle of rotation.} \item{\dots}{ Arguments passed to \code{\link{rotate.owin}} affecting the handling of the observation window, if it is a binary pixel mask. } \item{centre}{ Centre of rotation. Either a vector of length 2, or a character string (partially matched to \code{"centroid"}, \code{"midpoint"} or \code{"bottomleft"}). The default is the coordinate origin \code{c(0,0)}. } } \value{ Another object of class \code{"ppp"} representing the rotated point pattern. } \details{ The points of the pattern, and the window of observation, are rotated about the origin by the angle specified. Angles are measured in radians, anticlockwise. The default is to rotate the pattern 90 degrees anticlockwise. If the points carry marks, these are preserved. } \seealso{ \code{\link{ppp.object}}, \code{\link{rotate.owin}} } \examples{ X <- rotate(cells, pi/3) # plot(X) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/plot.splitppp.Rd0000644000176200001440000000306014611065347016743 0ustar liggesusers\name{plot.splitppp} \alias{plot.splitppp} \title{Plot a List of Point Patterns} \description{ Plots a list of point patterns. } \usage{ \method{plot}{splitppp}(x, \dots, main) } \arguments{ \item{x}{ A named list of point patterns, typically obtained from \code{\link{split.ppp}}. } \item{\dots}{ Arguments passed to \code{\link{plot.listof}} which control the layout of the plot panels, their appearance, and the plot behaviour in individual plot panels. } \item{main}{ Optional main title for the plot. } } \value{ Null. } \details{ This is the \code{plot} method for the class \code{"splitppp"}. It is typically used to plot the result of the function \code{\link{split.ppp}}. The argument \code{x} should be a named list of point patterns (objects of class \code{"ppp"}, see \code{\link{ppp.object}}). Each of these point patterns will be plotted in turn using \code{\link{plot.ppp}}. Plotting is performed by \code{\link{plot.listof}}. } \seealso{ \code{\link{plot.listof}} for arguments controlling the plot. \code{\link{split.ppp}}, \code{\link{plot.ppp}}, \code{\link{ppp.object}}. } \section{Error messages}{ If the error message \sQuote{Figure margins too large} occurs, ensure that \code{equal.scales=FALSE} and increase the values of \code{mar.panel}. } \examples{ # Multitype point pattern plot(split(amacrine)) plot(split(amacrine), main="", panel.begin=function(i, y, ...) { plot(distmap(y), ribbon=FALSE, ...) }) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{hplot} spatstat.geom/man/diameter.Rd0000644000176200001440000000171414611065345015707 0ustar liggesusers\name{diameter} \alias{diameter} \title{Diameter of an Object} \description{ Computes the diameter of an object such as a two-dimensional window or three-dimensional box. } \usage{ diameter(x) } \arguments{ \item{x}{ A window or other object whose diameter will be computed. } } \value{ The numerical value of the diameter of the object. } \details{ This function computes the diameter of an object such as a two-dimensional window or a three-dimensional box. The diameter is the maximum distance between any two points in the object. The function \code{diameter} is generic, with methods for the class \code{"owin"} (two-dimensional windows), \code{"box3"} (three-dimensional boxes), \code{"boxx"} (multi-dimensional boxes) and \code{"linnet"} (linear networks). } \seealso{ \code{\link{diameter.owin}}, \code{\link{diameter.box3}}, \code{\link{diameter.boxx}}, } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/as.data.frame.im.Rd0000644000176200001440000000164414611065345017127 0ustar liggesusers\name{as.data.frame.im} \alias{as.data.frame.im} \title{Convert Pixel Image to Data Frame} \description{ Convert a pixel image to a data frame } \usage{ \method{as.data.frame}{im}(x, ...) } \arguments{ \item{x}{A pixel image (object of class \code{"im"}).} \item{\dots}{Further arguments passed to \code{\link[base:as.data.frame]{as.data.frame.default}} to determine the row names and other features.} } \details{ This function takes the pixel image \code{x} and returns a data frame with three columns containing the pixel coordinates and the pixel values. The data frame entries are automatically sorted in increasing order of the \code{x} coordinate (and in increasing order of \code{y} within \code{x}). } \value{ A data frame. } \examples{ # artificial image Z <- setcov(square(1)) Y <- as.data.frame(Z) head(Y) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} spatstat.geom/man/methods.pp3.Rd0000644000176200001440000000314714611065347016265 0ustar liggesusers\name{methods.pp3} \Rdversion{1.1} \alias{methods.pp3} %DoNotExport \alias{print.pp3} \alias{summary.pp3} \alias{print.summary.pp3} \alias{unitname.pp3} \alias{unitname<-.pp3} \title{ Methods for three-dimensional point patterns } \description{ Methods for class \code{"pp3"}. } \usage{ \method{print}{pp3}(x, ...) \method{print}{summary.pp3}(x, ...) \method{summary}{pp3}(object, ...) \method{unitname}{pp3}(x) \method{unitname}{pp3}(x) <- value } \arguments{ \item{x,object}{ Object of class \code{"pp3"}. } \item{\dots}{ Ignored. } \item{value}{ Name of the unit of length. See \code{\link{unitname}}. } } \details{ These are methods for the generic functions \code{\link{print}}, \code{\link{summary}}, \code{\link{unitname}} and \code{\link{unitname<-}} for the class \code{"pp3"} of three-dimensional point patterns. The \code{print} and \code{summary} methods print a description of the point pattern. The \code{unitname} method extracts the name of the unit of length in which the point coordinates are expressed. The \code{unitname<-} method assigns the name of the unit of length. } \value{ For \code{print.pp3} the value is \code{NULL}. For \code{unitname.pp3} an object of class \code{"units"}. } \author{\adrian and \rolf } \seealso{ \code{\link{pp3}}, \code{\link{print}}, \code{\link{unitname}} \code{\link{unitname<-}} } \examples{ X <- pp3(runif(42),runif(42),runif(42), box3(c(0,1), unitname="mm")) X unitname(X) unitname(X) <- c("foot", "feet") summary(X) } \keyword{spatial} \keyword{methods} \concept{Three-dimensional} spatstat.geom/man/intensity.ppp.Rd0000644000176200001440000000540014611065346016736 0ustar liggesusers\name{intensity.ppp} \alias{intensity.ppp} \alias{intensity.splitppp} \title{ Empirical Intensity of Point Pattern } \description{ Computes the average number of points per unit area in a point pattern dataset. } \usage{ \method{intensity}{ppp}(X, ..., weights=NULL) \method{intensity}{splitppp}(X, ..., weights=NULL) } \arguments{ \item{X}{ A point pattern (object of class \code{"ppp"}). } \item{weights}{ Optional. Numeric vector of weights attached to the points of \code{X}. Alternatively, an \code{expression} which can be evaluated to give a vector of weights. } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link{intensity}}. It computes the empirical intensity of a point pattern (object of class \code{"ppp"}), i.e. the average density of points per unit area. If the point pattern is multitype, the intensities of the different types are computed separately. Note that the intensity will be computed as the number of points per square unit, based on the unit of length for \code{X}, given by \code{unitname(X)}. If the unit of length is a strange multiple of a standard unit, like \code{5.7 metres}, then it can be converted to the standard unit using \code{\link{rescale}}. See the Examples. If \code{weights} are given, then the intensity is computed as the total \emph{weight} per square unit. The argument \code{weights} should be a numeric vector of weights for each point of \code{X} (weights may be negative or zero). Alternatively \code{weights} can be an \code{expression} which will be evaluated for the dataset to yield a vector of weights. The expression may involve the Cartesian coordinates \eqn{x,y} of the points, and the marks of the points, if any. Variable names permitted in the expression include \code{x} and \code{y}, the name \code{marks} if \code{X} has a single column of marks, the names of any columns of marks if \code{X} has a data frame of marks, and the names of constants or functions that exist in the global environment. See the Examples. } \value{ A numeric value (giving the intensity) or numeric vector (giving the intensity for each possible type). } \seealso{ \code{\link{intensity}}, \code{\link[spatstat.model]{intensity.ppm}} } \examples{ japanesepines intensity(japanesepines) unitname(japanesepines) intensity(rescale(japanesepines)) intensity(amacrine) intensity(split(amacrine)) # numeric vector of weights volumes <- with(marks(finpines), (pi/4) * height * diameter^2) intensity(finpines, weights=volumes) # expression for weights intensity(finpines, weights=expression((pi/4) * height * diameter^2)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{nonparametric} spatstat.geom/man/colouroutputs.Rd0000644000176200001440000000321614611065345017063 0ustar liggesusers\name{colouroutputs} \alias{colouroutputs} \alias{colouroutputs<-} \title{ Extract or Assign Colour Values in a Colour Map } \description{ Extract the colour values in a colour map, or assign new colour values. } \usage{ colouroutputs(x) colouroutputs(x) <- value } \arguments{ \item{x}{ A colour map (object of class \code{"colourmap"}). } \item{value}{ A vector of values that can be interpreted as colours. } } \details{ An object of class \code{"colourmap"} is effectively a function that maps its inputs (numbers or factor levels) to colour values. The command \code{colouroutputs(x)} extracts the colour values in the colour map \code{x}. The assignment \code{colouroutputs(x) <- value} replaces the colour values in the colour map \code{x} by the entries in \code{value}. The replacement vector \code{value} should have the same length as \code{colouroutputs(x)}, and its entries should be interpretable as colours. To change only some of the colour values in a colour map, it may be easier to use \code{\link{tweak.colourmap}}. } \value{ The result of \code{colouroutputs} is a character vector of colour values. The result of the assignment \code{colouroutputs(x) <- value} is another colour map (object of class \code{"colourmap"}). } \seealso{ \code{\link{colourmap}}, \code{\link{interp.colourmap}}, \code{\link{tweak.colourmap}}, \code{\link[spatstat.geom:colourtools]{colourtools}}. } \examples{ m <- colourmap(rainbow(5), range=c(0,1)) m # reverse order of colours colouroutputs(m) <- rev(colouroutputs(m)) m } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{color} spatstat.geom/man/pixellate.psp.Rd0000644000176200001440000000523114643111575016705 0ustar liggesusers\name{pixellate.psp} \alias{pixellate.psp} \title{ Convert Line Segment Pattern to Pixel Image } \description{ Converts a line segment pattern to a pixel image by measuring the length or number of lines intersecting each pixel. } \usage{ \method{pixellate}{psp}(x, W=NULL, ..., weights = NULL, what=c("length", "number"), DivideByPixelArea=FALSE) } \arguments{ \item{x}{ Line segment pattern (object of class \code{"psp"}). } \item{W}{ Optional window (object of class \code{"owin"}) determining the pixel resolution. } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution. } \item{weights}{ Optional vector of weights associated with each line segment. } \item{what}{ String (partially matched) indicating whether to compute the total length of intersection (\code{what="length"}, the default) or the total number of segments intersecting each pixel (\code{what="number"}). } \item{DivideByPixelArea}{ Logical value, indicating whether the resulting pixel values should be divided by the pixel area. } } \details{ This function converts a line segment pattern to a pixel image by computing, for each pixel, the total length of intersection between the pixel and the line segments. Alternatively it can count the number of line segments intersecting each pixel. This is a method for the generic function \code{\link{pixellate}} for the class of line segment patterns. The pixel raster is determined by \code{W} and the optional arguments \code{\dots}. If \code{W} is missing or \code{NULL}, it defaults to the window containing \code{x}. Then \code{W} is converted to a binary pixel mask using \code{\link[spatstat.geom]{as.mask}}. The arguments \code{\dots} are passed to \code{\link[spatstat.geom]{as.mask}} to control the pixel resolution. If \code{weights} are given, then the length of the intersection between line segment \code{i} and pixel \code{j} is multiplied by \code{weights[i]} before the lengths are summed for each pixel. } \value{ A pixel image (object of class \code{"im"}) with numeric values. } \seealso{ \code{\link{pixellate}}, \code{\link[spatstat.geom]{as.mask}}, \code{\link{psp2mask}}. Use \code{\link{psp2mask}} if you only want to know which pixels are intersected by lines. } \examples{ X <- psp(runif(10),runif(10), runif(10), runif(10), window=owin()) plot(pixellate(X)) plot(X, add=TRUE) sum(lengths_psp(X)) sum(pixellate(X)) plot(pixellate(X, what="n")) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/boundingbox.Rd0000644000176200001440000000526514611065345016440 0ustar liggesusers\name{boundingbox} \alias{boundingbox} \alias{boundingbox.default} \alias{boundingbox.im} \alias{boundingbox.owin} \alias{boundingbox.ppp} \alias{boundingbox.psp} \alias{boundingbox.lpp} \alias{boundingbox.linnet} \alias{boundingbox.solist} \title{ Bounding Box of a Window, Image, or Point Pattern } \description{ Find the smallest rectangle containing a given window(s), image(s) or point pattern(s). } \usage{ boundingbox(\dots) \method{boundingbox}{default}(\dots) \method{boundingbox}{im}(\dots) \method{boundingbox}{owin}(\dots) \method{boundingbox}{ppp}(\dots) \method{boundingbox}{psp}(\dots) \method{boundingbox}{lpp}(\dots) \method{boundingbox}{linnet}(\dots) \method{boundingbox}{solist}(\dots) } \arguments{ \item{\dots}{One or more windows (objects of class \code{"owin"}), pixel images (objects of class \code{"im"}) or point patterns (objects of class \code{"ppp"} or \code{"lpp"}) or line segment patterns (objects of class \code{"psp"}) or linear networks (objects of class \code{"linnet"}) or any combination of such objects. Alternatively, the argument may be a list of such objects, of class \code{"solist"}. } } \details{ This function finds the smallest rectangle (with sides parallel to the coordinate axes) that contains all the given objects. For a window (object of class \code{"owin"}), the bounding box is the smallest rectangle that contains all the vertices of the window (this is generally smaller than the enclosing frame, which is returned by \code{\link{as.rectangle}}). For a point pattern (object of class \code{"ppp"} or \code{"lpp"}), the bounding box is the smallest rectangle that contains all the points of the pattern. This is usually smaller than the bounding box of the window of the point pattern. For a line segment pattern (object of class \code{"psp"}) or a linear network (object of class \code{"linnet"}), the bounding box is the smallest rectangle that contains all endpoints of line segments. For a pixel image (object of class \code{"im"}), the image will be converted to a window using \code{\link{as.owin}}, and the bounding box of this window is obtained. If the argument is a list of several objects, then this function finds the smallest rectangle that contains all the bounding boxes of the objects. } \value{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{as.rectangle}} } \examples{ w <- owin(c(0,10),c(0,10), poly=list(x=c(1,2,3,2,1), y=c(2,3,4,6,7))) r <- boundingbox(w) # returns rectangle [1,3] x [2,7] w2 <- unit.square() r <- boundingbox(w, w2) # returns rectangle [0,3] x [0,7] } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{utilities} spatstat.geom/man/matchingdist.Rd0000644000176200001440000000741014611065347016574 0ustar liggesusers\name{matchingdist} \alias{matchingdist} \title{Distance for a Point Pattern Matching} \description{ Computes the distance associated with a matching between two point patterns. } \usage{ matchingdist(matching, type = NULL, cutoff = NULL, q = NULL) } \arguments{ \item{matching}{A point pattern matching (an object of class \code{"pppmatching"}).} \item{type}{ A character string giving the type of distance to be computed. One of \code{"spa"}, \code{"ace"} or \code{"mat"}. See details below. } \item{cutoff}{ The value \eqn{> 0} at which interpoint distances are cut off. } \item{q}{ The order of the average that is applied to the interpoint distances. May be \code{Inf}, in which case the maximum of the interpoint distances is taken. } } \details{ Computes the distance specified by \code{type}, \code{cutoff}, and \code{order} for a point matching. If any of these arguments are not provided, the function uses the corresponding elements of \code{matching} (if available). For the type \code{"spa"} (subpattern assignment) it is assumed that the points of the point pattern with the smaller cardinality \eqn{m} are matched to a \eqn{m}-point subpattern of the point pattern with the larger cardinality \eqn{n} in a 1-1 way. The distance is then given as the \code{q}-th order average of the \eqn{m} distances between matched points (minimum of Euclidean distance and \code{cutoff}) and \eqn{n-m} "penalty distances" of value \code{cutoff}. For the type \code{"ace"} (assignment only if cardinalities equal) the matching is assumed to be 1-1 if the cardinalities of the point patterns are the same, in which case the \code{q}-th order average of the matching distances (minimum of Euclidean distance and \code{cutoff}) is taken. If the cardinalities are different, the matching may be arbitrary and the distance returned is always equal to \code{cutoff}. For the type \code{mat} (mass transfer) it is assumed that each point of the point pattern with the smaller cardinality \eqn{m} has mass \eqn{1}, each point of the point pattern with the larger cardinality \eqn{n} has mass \eqn{m/n}, and fractions of these masses are matched in such a way that each point contributes exactly its mass. The distance is then given as the \code{q}-th order weighted average of all distances (minimum of Euclidean distance and \code{cutoff}) of (partially) matched points with weights equal to the fractional masses divided by \eqn{m}. If the cardinalities of the two point patterns are equal, \code{matchingdist(m, type, cutoff, q)} yields the same result no matter if \code{type} is \code{"spa"}, \code{"ace"} or \code{"mat"}. } \value{ Numeric value of the distance associated with the matching. } \author{ \dominic. } \seealso{ \code{\link{pppdist}} \code{\link{pppmatching.object}} } \examples{ # an optimal matching X <- runifrect(20) Y <- runifrect(20) m.opt <- pppdist(X, Y) summary(m.opt) matchingdist(m.opt) # is the same as the distance given by summary(m.opt) # sequential nearest neighbour matching # (go through all points of point pattern X in sequence # and match each point with the closest point of Y that is # still unmatched) am <- matrix(0, 20, 20) h <- matrix(c(1:20, rep(0,20)), 20, 2) h[1,2] = nncross(X[1],Y)[1,2] for (i in 2:20) { nn <- nncross(X[i],Y[-h[1:(i-1),2]])[1,2] h[i,2] <- ((1:20)[-h[1:(i-1),2]])[nn] } am[h] <- 1 m.nn <- pppmatching(X, Y, am) matchingdist(m.nn, type="spa", cutoff=1, q=1) # is >= the distance obtained for m.opt # in most cases strictly > opa <- par(mfrow=c(1,2)) plot(m.opt, main="optimal") plot(m.nn, main="nearest neighbour") text(X, 1:20, pos=1, offset=0.3, cex=0.8) par(opa) } \keyword{spatial} \keyword{math} spatstat.geom/man/owin.Rd0000644000176200001440000001623714611065347015101 0ustar liggesusers\name{owin} \alias{owin} \title{Create a Window} \description{ Creates an object of class \code{"owin"} representing an observation window in the two-dimensional plane } \usage{ owin(xrange=c(0,1), yrange=c(0,1), ..., poly=NULL, mask=NULL, unitname=NULL, xy=NULL) } \arguments{ \item{xrange}{\eqn{x} coordinate limits of enclosing box} \item{yrange}{\eqn{y} coordinate limits of enclosing box} \item{\dots}{Ignored.} \item{poly}{ Optional. Polygonal boundary of window. Incompatible with \code{mask}. } \item{mask}{ Optional. Logical matrix giving binary image of window. Incompatible with \code{poly}. } \item{unitname}{ Optional. Name of unit of length. Either a single character string, or a vector of two character strings giving the singular and plural forms, respectively. } \item{xy}{ Optional. List with components \code{x} and \code{y} specifying the pixel coordinates for \code{mask}. } } \value{ An object of class \code{"owin"} describing a window in the two-dimensional plane. } \details{ In the \pkg{spatstat} library, a point pattern dataset must include information about the window of observation. This is represented by an object of class \code{"owin"}. See \code{\link{owin.object}} for an overview. To create a window in its own right, users would normally invoke \code{owin}, although sometimes \code{\link{as.owin}} may be convenient. A window may be rectangular, polygonal, or a mask (a binary image). \itemize{ \item \bold{rectangular windows:} If only \code{xrange} and \code{yrange} are given, then the window will be rectangular, with its \eqn{x} and \eqn{y} coordinate dimensions given by these two arguments (which must be vectors of length 2). If no arguments are given at all, the default is the unit square with dimensions \code{xrange=c(0,1)} and \code{yrange=c(0,1)}. \item \bold{polygonal windows:} If \code{poly} is given, then the window will be polygonal. \itemize{ \item \emph{single polygon:} If \code{poly} is a matrix or data frame with two columns, or a structure with two component vectors \code{x} and \code{y} of equal length, then these values are interpreted as the cartesian coordinates of the vertices of a polygon circumscribing the window. The vertices must be listed \emph{anticlockwise}. No vertex should be repeated (i.e. do not repeat the first vertex). \item \emph{multiple polygons or holes:} If \code{poly} is a list, each entry \code{poly[[i]]} of which is a matrix or data frame with two columns or a structure with two component vectors \code{x} and \code{y} of equal length, then the successive list members \code{poly[[i]]} are interpreted as separate polygons which together make up the boundary of the window. The vertices of each polygon must be listed \emph{anticlockwise} if the polygon is part of the external boundary, but \emph{clockwise} if the polygon is the boundary of a hole in the window. Again, do not repeat any vertex. } \item \bold{binary masks:} If \code{mask} is given, then the window will be a binary image. \itemize{ \item \emph{Specified by logical matrix:} Normally the argument \code{mask} should be a logical matrix such that \code{mask[i,j]} is \code{TRUE} if the point \code{(x[j],y[i])} belongs to the window, and \code{FALSE} if it does not (\code{NA} entries will be treated as \code{FALSE}). Note carefully that rows of \code{mask} correspond to the \eqn{y} coordinate, and columns to the \eqn{x} coordinate. Here \code{x} and \code{y} are vectors of \eqn{x} and \eqn{y} coordinates equally spaced over \code{xrange} and \code{yrange} respectively. The pixel coordinate vectors \code{x} and \code{y} may be specified explicitly using the argument \code{xy}, which should be a list containing components \code{x} and \code{y}. Alternatively there is a sensible default. \item \emph{Specified by list of pixel coordinates:} Alternatively the argument \code{mask} can be a data frame with 2 or 3 columns. If it has 2 columns, it is expected to contain the spatial coordinates of all the pixels which are inside the window. If it has 3 columns, it should contain the spatial coordinates \eqn{(x,y)} of every pixel in the grid, and the logical value associated with each pixel. The pixels may be listed in any order. } } To create a window which is mathematically defined by inequalities in the Cartesian coordinates, use \code{\link{raster.x}()} and \code{\link{raster.y}()} as in the examples below. Functions \code{\link{square}} and \code{\link{disc}} will create square and circular windows, respectively. } \section{Validity of polygon data}{ Polygon data may contain geometrical inconsistencies such as self-intersections and overlaps. These inconsistencies must be removed to prevent problems in other \pkg{spatstat} functions. By default, polygon data will be repaired automatically using polygon-clipping code. The repair process may change the number of vertices in a polygon and the number of polygon components. To disable the repair process, set \code{spatstat.options(fixpolygons=FALSE)}. } \seealso{ \code{\link{owin.object}}, \code{\link{as.owin}}, \code{\link{complement.owin}}, \code{\link{ppp.object}}, \code{\link{ppp}} \code{\link{square}}, \code{\link{hexagon}}, \code{\link{regularpolygon}}, \code{\link{disc}}, \code{\link{ellipse}}. } \examples{ w <- owin() w <- owin(c(0,1), c(0,1)) # the unit square w <- owin(c(10,20), c(10,30), unitname=c("foot","feet")) # a rectangle of dimensions 10 x 20 feet # with lower left corner at (10,10) # polygon (diamond shape) w <- owin(poly=list(x=c(0.5,1,0.5,0),y=c(0,1,2,1))) w <- owin(c(0,1), c(0,2), poly=list(x=c(0.5,1,0.5,0),y=c(0,1,2,1))) # polygon with hole ho <- owin(poly=list(list(x=c(0,1,1,0), y=c(0,0,1,1)), list(x=c(0.6,0.4,0.4,0.6), y=c(0.2,0.2,0.4,0.4)))) w <- owin(c(-1,1), c(-1,1), mask=matrix(TRUE, 100,100)) # 100 x 100 image, all TRUE X <- raster.x(w) Y <- raster.y(w) wm <- owin(w$xrange, w$yrange, mask=(X^2 + Y^2 <= 1)) # discrete approximation to the unit disc # vertices of a polygon (listed anticlockwise) bdry <- list(x=c(0.1,0.3,0.7,0.4,0.2), y=c(0.1,0.1,0.5,0.7,0.3)) # vertices could alternatively be read from a file, or use locator() w <- owin(poly=bdry) \dontrun{ # how to read in a binary mask from a file im <- as.logical(matrix(scan("myfile"), nrow=128, ncol=128)) # read in an arbitrary 128 x 128 digital image from text file rim <- im[, 128:1] # Assuming it was given in row-major order in the file # i.e. scanning left-to-right in rows from top-to-bottom, # the use of matrix() has effectively transposed rows & columns, # so to convert it to our format just reverse the column order. w <- owin(mask=rim) plot(w) # display it to check! } } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/vertices.Rd0000644000176200001440000000255714611065351015744 0ustar liggesusers\name{vertices} \alias{vertices} \alias{vertices.owin} \title{Vertices of a Window} \description{ Finds the vertices of a window, or similar object. } \usage{ vertices(w) \method{vertices}{owin}(w) } \arguments{ \item{w}{A window (object of class \code{"owin"}) or similar object.} } \value{ A list with components \code{x} and \code{y} giving the coordinates of the vertices. } \details{ This function computes the vertices (`corners') of a spatial window or other object. For \code{vertices.owin}, the argument \code{w} should be a window (an object of class \code{"owin"}, see \code{\link{owin.object}} for details). If \code{w} is a rectangle, the coordinates of the four corner points are returned. If \code{w} is a polygonal window (consisting of one or more polygons), the coordinates of the vertices of all polygons are returned. If \code{w} is a binary mask, then a `boundary pixel' is defined to be a pixel inside the window which has at least one neighbour outside the window. The coordinates of the centres of all boundary pixels are returned. } \seealso{ \code{\link{owin.object}}. } \examples{ vert <- vertices(letterR) plot(letterR, main="Polygonal vertices") points(vert) plot(letterR, main="Boundary pixels") points(vertices(as.mask(letterR))) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/plot.imlist.Rd0000644000176200001440000000677114722270274016405 0ustar liggesusers\name{plot.imlist} \alias{plot.imlist} \alias{image.imlist} \alias{image.listof} \title{Plot a List of Images} \description{ Plots an array of pixel images. } \usage{ \method{plot}{imlist}(x, \dots, plotcommand="image", equal.ribbon=FALSE, equal.scales=FALSE, ribmar=NULL) \method{image}{imlist}(x, \dots, equal.ribbon=FALSE, equal.scales=FALSE, ribmar=NULL) \method{image}{listof}(x, \dots, equal.ribbon=FALSE, equal.scales=FALSE, ribmar=NULL) } \arguments{ \item{x}{ An object of the class \code{"imlist"} representing a list of pixel images. Alternatively \code{x} may belong to the outdated class \code{"listof"}. } \item{\dots}{ Arguments passed to \code{\link{plot.solist}} to control the spatial arrangement of panels, and arguments passed to \code{\link{plot.im}} to control the display of each panel. } \item{equal.ribbon}{ Logical. If \code{TRUE}, the colour maps of all the images will be the same. If \code{FALSE}, the colour map of each image is adjusted to the range of values of that image. } \item{equal.scales}{ Logical. If \code{TRUE}, the images will be plotted using the same physical scale, and the plots will be aligned neatly where possible. } \item{ribmar}{ Numeric vector of length 4 specifying the margins around the colour ribbon, if \code{equal.ribbon=TRUE}. Entries in the vector give the margin at the bottom, left, top, and right respectively, as a multiple of the height of a line of text. } \item{plotcommand}{ Character string giving the name of a function to be used to display each image. Recognised by \code{plot.imlist} only. } } \value{ Null. } \details{ These are methods for the generic plot commands \code{plot} and \code{image} for the class \code{"imlist"}. They are currently identical. An object of class \code{"imlist"} represents a list of pixel images. (The outdated class \code{"listof"} is also handled.) Each entry in the list \code{x} will be displayed as a pixel image, in an array of panels laid out on the same graphics display, using \code{\link{plot.solist}}. Individual panels are plotted by \code{\link{plot.im}}. If \code{equal.ribbon=FALSE} (the default), the images are rendered using different colour maps, which are displayed as colour ribbons beside each image. If \code{equal.ribbon=TRUE}, the images are rendered using the same colour map, and a single colour ribbon will be displayed at the right side of the array. The colour maps and the placement of the colour ribbons are controlled by arguments \code{\dots} passed to \code{\link{plot.im}}. If \code{equal.scales=TRUE}, the images are plotted using the same physical scale, and the plots will be aligned neatly where possible. If \code{equal.scales=FALSE} (the default), images are plotted using equal amounts of space in the available plotting area, so they may be plotted at different physical scales. } \seealso{ \code{\link{plot.solist}}, \code{\link{plot.im}} } \examples{ ## bei.extra is a list of pixel images on the same spatial domain Y <- solapply(bei.extra, scaletointerval) image(Y, equal.ribbon=TRUE, equal.scales=TRUE, main="", mar.panel=0, hsep=1, ribside="bottom", col.ticks="blue", col.axis="blue", cex.axis=1.2) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/nestsplit.Rd0000644000176200001440000000447414611065347016152 0ustar liggesusers\name{nestsplit} \alias{nestsplit} \title{ Nested Split } \description{ Applies two splitting operations to a point pattern, producing a list of lists of patterns. } \usage{ nestsplit(X, \dots) } \arguments{ \item{X}{ Point pattern to be split. Object of class \code{"ppp"}. } \item{\dots}{ Data determining the splitting factors or splitting regions. See Details. } } \details{ This function splits the point pattern \code{X} into several sub-patterns using \code{\link{split.ppp}}, then splits each of the sub-patterns into sub-sub-patterns using \code{\link{split.ppp}} again. The result is a hyperframe containing the sub-sub-patterns and two factors indicating the grouping. The arguments \code{\dots} determine the two splitting factors or splitting regions. Each argument may be: \itemize{ \item a factor (of length equal to the number of points in \code{X}) \item the name of a column of marks of \code{X} (provided this column contains factor values) \item a tessellation (class \code{"tess"}) \item a pixel image (class \code{"im"}) with factor values \item a window (class \code{"owin"}) \item identified by name (in the form \code{name=value}) as one of the formal arguments of \code{\link{quadrats}} or \code{\link{tess}} } The arguments will be processed to yield a list of two splitting factors/tessellations. The splits will be applied to \code{X} consecutively to produce the sub-sub-patterns. } \value{ A hyperframe with three columns. The first column contains the sub-sub-patterns. The second and third columns are factors which identify the grouping according to the two splitting factors. } \author{ Original idea by Ute Hahn. Code by \spatstatAuthors. } \seealso{ \code{\link{split.ppp}}, \code{\link{quantess}} } \examples{ # factor and tessellation Nft <- nestsplit(amacrine, marks(amacrine), quadrats(amacrine, 3, 1)) Ntf <- nestsplit(amacrine, quadrats(amacrine, 3, 1), marks(amacrine)) Ntf # two factors big <- with(marks(betacells), area > 300) Nff <- nestsplit(betacells, "type", factor(big)) # two tessellations Tx <- quantess(redwood, "x", 4) Td <- dirichlet(runifrect(5, Window(redwood))) Ntt <- nestsplit(redwood, Td, Tx) Ntt2 <- nestsplit(redwood, Td, ny=3) } \keyword{spatial} \keyword{manip} spatstat.geom/man/pppdist.Rd0000644000176200001440000002204014611065350015567 0ustar liggesusers\name{pppdist} \alias{pppdist} \title{Distance Between Two Point Patterns} \description{ Given two point patterns, find the distance between them based on optimal point matching. } \usage{ pppdist(X, Y, type = "spa", cutoff = 1, q = 1, matching = TRUE, ccode = TRUE, auction = TRUE, precision = NULL, approximation = 10, show.rprimal = FALSE, timelag = 0) } \arguments{ \item{X,Y}{Two point patterns (objects of class \code{"ppp"}).} \item{type}{ A character string giving the type of distance to be computed. One of \code{"spa"} (default), \code{"ace"} or \code{"mat"}, indicating whether the algorithm should find the optimal matching based on \dQuote{subpattern assignment}, \dQuote{assignment only if cardinalities are equal} or \dQuote{mass transfer}. See Details. } \item{cutoff}{ The value \eqn{> 0} at which interpoint distances are cut off. } \item{q}{ The order of the average that is applied to the interpoint distances. May be \code{Inf}, in which case the maximum of the interpoint distances is taken. } \item{matching}{ Logical. Whether to return the optimal matching or only the associated distance. } \item{ccode}{ Logical. If \code{FALSE}, \R code is used which allows for higher precision, but is much slower. } \item{auction}{ Logical. By default a version of Bertsekas' auction algorithm is used to compute an optimal point matching if \code{type} is either \code{"spa"} or \code{"ace"}. If \code{auction} is \code{FALSE} (or \code{type} is \code{"mat"}) a specialized primal-dual algorithm is used instead. This was the standard in earlier versions of \pkg{spatstat}, but is several orders of magnitudes slower. } \item{precision}{ Index controlling accuracy of algorithm. The \code{q}-th powers of interpoint distances will be rounded to the nearest multiple of \code{10^(-precision)}. There is a sensible default which depends on \code{ccode}. } \item{approximation}{ If \code{q = Inf}, compute distance based on the optimal matching for the corresponding distance of order \code{approximation}. Can be \code{Inf}, but this makes computations extremely slow. } \item{show.rprimal}{ Logical. Whether to plot the progress of the primal-dual algorithm. If \code{TRUE}, slow primal-dual \R code is used, regardless of the arguments \code{ccode} and \code{auction}. } \item{timelag}{ Time lag, in seconds, between successive displays of the iterative solution of the restricted primal problem. } } \details{ Computes the distance between point patterns \code{X} and \code{Y} based on finding the matching between them which minimizes the average of the distances between matched points (if \code{q=1}), the maximum distance between matched points (if \code{q=Inf}), and in general the \code{q}-th order average (i.e. the \code{1/q}th power of the sum of the \code{q}th powers) of the distances between matched points. Distances between matched points are Euclidean distances cut off at the value of \code{cutoff}. The parameter \code{type} controls the behaviour of the algorithm if the cardinalities of the point patterns are different. For the type \code{"spa"} (subpattern assignment) the subpattern of the point pattern with the larger cardinality \eqn{n} that is closest to the point pattern with the smaller cardinality \eqn{m} is determined; then the \code{q}-th order average is taken over \eqn{n} values: the \eqn{m} distances of matched points and \eqn{n-m} "penalty distances" of value \code{cutoff} for the unmatched points. For the type \code{"ace"} (assignment only if cardinalities equal) the matching is empty and the distance returned is equal to \code{cutoff} if the cardinalities differ. For the type \code{"mat"} (mass transfer) each point pattern is assumed to have total mass \eqn{m} (= the smaller cardinality) distributed evenly among its points; the algorithm finds then the "mass transfer plan" that minimizes the \code{q}-th order weighted average of the distances, where the weights are given by the transferred mass divided by \eqn{m}. The result is a fractional matching (each match of two points has a weight in \eqn{(0,1]}) with the minimized quantity as the associated distance. The central problem to be solved is the assignment problem (for types \code{"spa"} and \code{"ace"}) or the more general transport problem (for type \code{"mat"}). Both are well-known problems in discrete optimization, see e.g. Luenberger (2003). For the assignment problem \code{pppdist} uses by default the forward/backward version of Bertsekas' auction algorithm with automated epsilon scaling; see Bertsekas (1992). The implemented version gives good overall performance and can handle point patterns with several thousand points. For the transport problem a specialized primal-dual algorithm is employed; see Luenberger (2003), Section 5.9. The C implementation used by default can handle patterns with a few hundreds of points, but should not be used with thousands of points. By setting \code{show.rprimal = TRUE}, some insight in the working of the algorithm can be gained. For a broader selection of optimal transport algorithms that are not restricted to spatial point patterns and allow for additional fine tuning, we recommend the \R package \pkg{transport}. For moderate and large values of \code{q} there can be numerical issues based on the fact that the \code{q}-th powers of distances are taken and some positive values enter the optimization algorithm as zeroes because they are too small in comparison with the larger values. In this case the number of zeroes introduced is given in a warning message, and it is possible then that the matching obtained is not optimal and the associated distance is only a strict upper bound of the true distance. As a general guideline (which can be very wrong in special situations) a small number of zeroes (up to about 50\% of the smaller point pattern cardinality \eqn{m}) usually still results in the right matching, and the number can even be quite a bit higher and usually still provides a highly accurate upper bound for the distance. These numerical problems can be reduced by enforcing (much slower) \R code via the argument \code{ccode = FALSE}. For \code{q = Inf} there is no fast algorithm available, which is why approximation is normally used: for finding the optimal matching, \code{q} is set to the value of \code{approximation}. The resulting distance is still given as the maximum rather than the \code{q}-th order average in the corresponding distance computation. If \code{approximation = Inf}, approximation is suppressed and a very inefficient exhaustive search for the best matching is performed. The value of \code{precision} should normally not be supplied by the user. If \code{ccode = TRUE}, this value is preset to the highest exponent of 10 that the C code still can handle (usually \eqn{9}). If \code{ccode = FALSE}, the value is preset according to \code{q} (usually \eqn{15} if \code{q} is small), which can sometimes be changed to obtain less severe warning messages. } \value{ Normally an object of class \code{pppmatching} that contains detailed information about the parameters used and the resulting distance. See \code{\link{pppmatching.object}} for details. If \code{matching = FALSE}, only the numerical value of the distance is returned. } \references{ Bertsekas, D.P. (1992). Auction algorithms for network flow problems: a tutorial introduction. Computational Optimization and Applications 1, 7-66. Luenberger, D.G. (2003). \emph{Linear and nonlinear programming.} Second edition. Kluwer. Schuhmacher, D. (2014). \emph{transport: optimal transport in various forms.} R package version 0.6-2 (or later) Schuhmacher, D. and Xia, A. (2008). A new metric between distributions of point processes. \emph{Advances in Applied Probability} \bold{40}, 651--672 Schuhmacher, D., Vo, B.-T. and Vo, B.-N. (2008). A consistent metric for performance evaluation of multi-object filters. \emph{IEEE Transactions on Signal Processing} \bold{56}, 3447--3457. } \author{ \dominic. } \seealso{ \code{\link{pppmatching.object}}, \code{\link{matchingdist}}, \code{\link{plot.pppmatching}} } \examples{ # equal cardinalities set.seed(140627) X <- runifrect(500) Y <- runifrect(500) m <- pppdist(X, Y) m if(interactive()) { plot(m)} # differing cardinalities X <- runifrect(14) Y <- runifrect(10) m1 <- pppdist(X, Y, type="spa") m2 <- pppdist(X, Y, type="ace") m3 <- pppdist(X, Y, type="mat", auction=FALSE) summary(m1) summary(m2) summary(m3) if(interactive()) { m1$matrix m2$matrix m3$matrix} # q = Inf X <- runifrect(10) Y <- runifrect(10) mx1 <- pppdist(X, Y, q=Inf, matching=FALSE) mx2 <- pppdist(X, Y, q=Inf, matching=FALSE, ccode=FALSE, approximation=50) mx3 <- pppdist(X, Y, q=Inf, matching=FALSE, approximation=Inf) all.equal(mx1,mx2,mx3) # sometimes TRUE all.equal(mx2,mx3) # very often TRUE } \keyword{spatial} \keyword{math} spatstat.geom/man/cut.im.Rd0000644000176200001440000000311414611065345015310 0ustar liggesusers\name{cut.im} \alias{cut.im} \title{Convert Pixel Image from Numeric to Factor} \description{ Transform the values of a pixel image from numeric values into a factor. } \usage{ \method{cut}{im}(x, \dots) } \arguments{ \item{x}{ A pixel image. An object of class \code{"im"}. } \item{\dots}{ Arguments passed to \code{\link{cut.default}}. They determine the breakpoints for the mapping from numerical values to factor values. See \code{\link{cut.default}}. } } \value{ A pixel image (object of class \code{"im"}) with pixel values that are a factor. See \code{\link{im.object}}. } \details{ This simple function applies the generic \code{\link{cut}} operation to the pixel values of the image \code{x}. The range of pixel values is divided into several intervals, and each interval is associated with a level of a factor. The result is another pixel image, with the same window and pixel grid as \code{x}, but with the numeric value of each pixel discretised by replacing it by the factor level. This function is a convenient way to inspect an image and to obtain summary statistics. See the examples. To select a subset of an image, use the subset operator \code{\link{[.im}} instead. } \seealso{ \code{\link{cut}}, \code{\link{im.object}} } \examples{ # artificial image data Z <- setcov(square(1)) Y <- cut(Z, 3) Y <- cut(Z, breaks=seq(0,1,length=5)) # cut at the quartiles # (divides the image into 4 equal areas) Y <- cut(Z, quantile(Z)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/Extract.tess.Rd0000644000176200001440000000447114611065346016510 0ustar liggesusers\name{Extract.tess} \alias{[.tess} \alias{[<-.tess} \title{Extract or Replace Subset of Tessellation} \description{ Extract, change or delete a subset of the tiles of a tessellation, to make a new tessellation. } \usage{ \method{[}{tess}(x, i, \dots) \method{[}{tess}(x, i, \dots) <- value } \arguments{ \item{x}{A tessellation (object of class \code{"tess"}).} \item{i}{ Subset index for the tiles of the tessellation. Alternatively a window (object of class \code{"owin"}). } \item{\dots}{ One argument that specifies the subset to be extracted or changed. Any valid format for the subset index in a list. } \item{value}{ Replacement value for the selected tiles of the tessellation. A list of windows (objects of class \code{"owin"}) or \code{NULL}. } } \details{ A tessellation (object of class \code{"tess"}, see \code{\link{tess}}) is effectively a list of tiles (spatial regions) that cover a spatial region. The subset operator \code{[.tess} extracts some of these tiles and forms a new tessellation, which of course covers a smaller region than the original. For \code{[.tess} only, the subset index can also be a window (object of class \code{"owin"}). The tessellation \code{x} is then intersected with the window. The replacement operator changes the selected tiles. The replacement \code{value} may be either \code{NULL} (which causes the selected tiles to be removed from \code{x}) or a list of the same length as the selected subset. The entries of \code{value} may be windows (objects of class \code{"owin"}) or \code{NULL} to indicate that the corresponding tile should be deleted. Generally it does not make sense to replace a tile in a tessellation with a completely different tile, because the tiles are expected to fit together. However this facility is sometimes useful for making small adjustments to polygonal tiles. } \value{ A tessellation (object of class \code{"tess"}). } \seealso{ \code{\link{tess}}, \code{\link{tiles}}, \code{\link{intersect.tess}}. } \examples{ \testonly{op <- spatstat.options(npixel=10)} A <- tess(xgrid=0:4, ygrid=0:3) B <- A[c(1, 3, 7)] E <- A[-1] A[c(2, 5, 11)] <- NULL \testonly{spatstat.options(op)} } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} \concept{Tessellation} spatstat.geom/man/pixellate.owin.Rd0000644000176200001440000000450614643111575017063 0ustar liggesusers\name{pixellate.owin} \Rdversion{1.1} \alias{pixellate.owin} \title{ Convert Window to Pixel Image } \description{ Convert a window to a pixel image by measuring the area of intersection between the window and each pixel in a raster. } \usage{ \method{pixellate}{owin}(x, W = NULL, ..., DivideByPixelArea=FALSE) } \arguments{ \item{x}{ Window (object of class \code{"owin"}) to be converted. } \item{W}{ Optional. Window determining the pixel raster on which the conversion should occur. } \item{\dots}{ Optional. Extra arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel raster. } \item{DivideByPixelArea}{ Logical value, indicating whether the resulting pixel values should be divided by the pixel area. } } \details{ This is a method for the generic function \code{pixellate}. It converts a window \code{x} into a pixel image, by measuring the \emph{amount} of \code{x} that is inside each pixel. (The related function \code{\link{as.im}} also converts \code{x} into a pixel image, but records only the presence or absence of \code{x} in each pixel.) The pixel raster for the conversion is determined by the argument \code{W} and the extra arguments \code{\dots}. \itemize{ \item If \code{W} is given, and it is a binary mask (a window of type \code{"mask"}) then it determines the pixel raster. \item If \code{W} is given, but it is not a binary mask (it is a window of another type) then it will be converted to a binary mask using \code{as.mask(W, \dots)}. \item If \code{W} is not given, it defaults to \code{as.mask(as.rectangle(x), \dots)} } In the second and third cases it would be common to use the argument \code{dimyx} to control the number of pixels. See the Examples. The algorithm then computes the area of intersection of each pixel with the window. The result is a pixel image with pixel entries equal to these intersection areas. } \value{ A pixel image (object of class \code{"im"}). } \seealso{ \code{\link{pixellate.ppp}}, \code{\link{pixellate}}, \code{\link{as.im}} } \examples{ plot(pixellate(letterR, dimyx=15)) W <- grow.rectangle(as.rectangle(letterR), 0.2) plot(pixellate(letterR, W, dimyx=15)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/Extract.quad.Rd0000644000176200001440000000221414611065346016455 0ustar liggesusers\name{Extract.quad} \alias{[.quad} \title{Subset of Quadrature Scheme} \description{ Extract a subset of a quadrature scheme. } \usage{ \method{[}{quad}(x, ...) } \arguments{ \item{x}{ A quadrature scheme (object of class \code{"quad"}). } \item{\dots}{ Arguments passed to \code{\link{[.ppp}} to determine the subset. } } \value{ A quadrature scheme (object of class \code{"quad"}). } \details{ This function extracts a designated subset of a quadrature scheme. The function \code{[.quad} is a method for \code{\link{[}} for the class \code{"quad"}. It extracts a designated subset of a quadrature scheme. The subset to be extracted is determined by the arguments \code{\dots} which are interpreted by \code{\link{[.ppp}}. Thus it is possible to take the subset consisting of all quadrature points that lie inside a given region, or a subset of quadrature points identified by numeric indices. } \seealso{ \code{\link{quad.object}}, \code{\link{[.ppp}}. } \examples{ Q <- quadscheme(nztrees) W <- owin(c(0,148),c(0,95)) # a subwindow Q[W] } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/summary.quad.Rd0000644000176200001440000000313114611065350016532 0ustar liggesusers\name{summary.quad} \alias{summary.quad} \alias{print.summary.quad} \title{Summarizing a Quadrature Scheme} \description{ \code{summary} method for class \code{"quad"}. } \usage{ \method{summary}{quad}(object, \dots, checkdup=FALSE) \method{print}{summary.quad}(x, \dots, dp=3) } \arguments{ \item{object}{A quadrature scheme.} \item{\dots}{Ignored.} \item{checkdup}{ Logical value indicating whether to test for duplicated points. } \item{dp}{Number of significant digits to print.} \item{x}{Object of class \code{"summary.quad"} returned by \code{summary.quad}.} } \details{ This is a method for the generic \code{\link{summary}} for the class \code{"quad"}. An object of class \code{"quad"} describes a quadrature scheme, used to fit a point process model. See \code{\link{quad.object}}) for details of this class. \code{summary.quad} extracts information about the quadrature scheme, and \code{print.summary.quad} prints this information in a comprehensible format. In normal usage, \code{print.summary.quad} is invoked implicitly when the user calls \code{summary.quad} without assigning its value to anything. See the examples. } \value{ \code{summary.quad} returns an object of class \code{"summary.quad"}, while \code{print.summary.quad} returns \code{NULL}. } \examples{ # make a quadrature scheme Q <- quadscheme(runifrect(42)) # summarize it summary(Q) # save the summary s <- summary(Q) # print it print(s) s # extract total quadrature weight s$w$all$sum } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/Window.tess.Rd0000644000176200001440000000237414643111575016346 0ustar liggesusers\name{Window.tess} \alias{Window.quadratcount} \alias{Window.tess} \alias{Window.layered} \alias{Window.distfun} \alias{Window.nnfun} \alias{Window.funxy} \title{Extract Window of Spatial Object} \description{ Given a spatial object (such as a point pattern or pixel image) in two dimensions, these functions extract the window in which the object is defined. } \usage{ \method{Window}{quadratcount}(X, \dots) \method{Window}{tess}(X, \dots) \method{Window}{layered}(X, \dots) \method{Window}{distfun}(X, \dots) \method{Window}{nnfun}(X, \dots) \method{Window}{funxy}(X, \dots) } \arguments{ \item{X}{A spatial object.} \item{\dots}{Ignored.} } \value{ An object of class \code{"owin"} (see \code{\link[spatstat.geom]{owin.object}}) specifying an observation window. } \details{ These are methods for the generic function \code{\link[spatstat.geom]{Window}} which extract the spatial window in which the object \code{X} is defined. } \seealso{ \code{\link[spatstat.geom]{Window}}, \code{\link[spatstat.geom]{Window.ppp}}, \code{\link[spatstat.geom]{Window.psp}}. \code{\link[spatstat.geom]{owin.object}} } \examples{ A <- quadratcount(cells, 4) Window(A) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/subset.ppp.Rd0000644000176200001440000001120114611065350016204 0ustar liggesusers\name{subset.ppp} \alias{subset.ppp} \alias{subset.pp3} \alias{subset.ppx} \title{ Subset of Point Pattern Satisfying A Condition } \description{ Given a point pattern, return the subset of points which satisfy a specified condition. } \usage{ \method{subset}{ppp}(x, subset, select, drop=FALSE, \dots) \method{subset}{pp3}(x, subset, select, drop=FALSE, \dots) \method{subset}{ppx}(x, subset, select, drop=FALSE, \dots) } \arguments{ \item{x}{ A point pattern (object of class \code{"ppp"}, \code{"lpp"}, \code{"pp3"} or \code{"ppx"}). } \item{subset}{ Logical expression indicating which points are to be kept. The expression may involve the names of spatial coordinates (\code{x}, \code{y}, etc), the \code{marks}, and (if there is more than one column of marks) the names of individual columns of marks. Missing values are taken as false. See Details. } \item{select}{ Expression indicating which columns of marks should be kept. The \emph{names} of columns of marks can be used in this expression, and will be treated as if they were column indices. See Details. } \item{drop}{ Logical value indicating whether to remove unused levels of the marks, if the marks are a factor. } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link[base]{subset}}. It extracts the subset of points of \code{x} that satisfy the logical expression \code{subset}, and retains only the columns of marks that are specified by the expression \code{select}. The result is always a point pattern, with the same window as \code{x}. The argument \code{subset} determines the subset of points that will be extracted. It should be a logical expression. It may involve the variable names \code{x} and \code{y} representing the Cartesian coordinates; the names of other spatial coordinates or local coordinates; the name \code{marks} representing the marks; and (if there is more than one column of marks) the names of individual columns of marks. The default is to keep all points. The argument \code{select} determines which columns of marks will be retained (if there are several columns of marks). It should be an expression involving the names of columns of marks (which will be interpreted as integers representing the positions of these columns). For example if there are columns of marks named \code{A} to \code{Z}, then \code{select=D:F} is a valid expression and means that columns \code{D}, \code{E} and \code{F} will be retained. Similarly \code{select=-(A:C)} is valid and means that columns \code{A} to \code{C} will be deleted. The default is to retain all columns. Setting \code{subset=FALSE} will produce an empty point pattern (i.e. containing zero points) in the same window as \code{x}. Setting \code{select=FALSE} or \code{select= -marks} will remove all the marks from \code{x}. The argument \code{drop} determines whether to remove unused levels of a factor, if the resulting point pattern is multitype (i.e. the marks are a factor) or if the marks are a data frame in which some of the columns are factors. The result is always a point pattern, of the same class as \code{x}. Spatial coordinates (and local coordinates) are always retained. To extract only some columns of marks or coordinates as a data frame, use \code{subset(as.data.frame(x), ...)} } \section{Other kinds of subset arguments}{ Alternatively the argument \code{subset} can be any kind of subset index acceptable to \code{\link{[.ppp}}, \code{\link{[.pp3}}, \code{\link{[.ppx}}. This argument selects which points of \code{x} will be retained. \bold{Warning:} if the argument \code{subset} is a window, this is interpreted as specifying the subset of points that fall inside that window, but the resulting point pattern has the same window as the original pattern \code{x}. } \value{ A point pattern of the same class as \code{x}, in the same spatial window as \code{x}. The result is a subset of \code{x}, possibly with some columns of marks removed. } \author{ \spatstatAuthors. } \seealso{ \code{\link[base]{subset}}, \code{\link{[.ppp}}, \code{\link{[.pp3}}, \code{\link{[.ppx}} } \examples{ plot(subset(cells, x > 0.5)) subset(amacrine, marks == "on") subset(amacrine, marks == "on", drop=TRUE) subset(redwood, nndist(redwood) > 0.04) subset(finpines, select=height) subset(finpines, diameter > 2, height) subset(nbfires, year==1999 & ign.src == "campfire", select=cause:fnl.size) if(require(spatstat.random)) { a <- subset(rpoispp3(40), z > 0.5) } } \keyword{spatial} \keyword{manip} spatstat.geom/man/persp.im.Rd0000644000176200001440000001364514611065347015662 0ustar liggesusers\name{persp.im} \alias{persp.im} \title{Perspective Plot of Pixel Image} \description{ Displays a perspective plot of a pixel image. } \usage{ \method{persp}{im}(x, \dots, colmap=NULL, colin=x, apron=FALSE, visible=FALSE) } \arguments{ \item{x}{ The pixel image to be plotted as a surface. An object of class \code{"im"} (see \code{\link{im.object}}). } \item{\dots}{ Extra arguments passed to \code{\link{persp.default}} to control the display. } \item{colmap}{ Optional data controlling the colour map. See Details. } \item{colin}{ Optional. Colour input. Another pixel image (of the same dimensions as \code{x}) containing the values that will be mapped to colours. } \item{apron}{ Logical. If \code{TRUE}, a grey apron is placed around the sides of the perspective plot. } \item{visible}{ Logical value indicating whether to compute which pixels of \code{x} are visible in the perspective view. See Details. } } \value{ (invisibly) the 3D transformation matrix returned by \code{\link{persp.default}}, together with an attribute \code{"expand"} which gives the relative scale of the \eqn{z} coordinate. If argument \code{visible=TRUE} was given, the return value also has an attribute \code{"visible"} which is a pixel image, compatible with \code{x}, with logical values which are \emph{TRUE} when the corresponding pixel is visible in the perspective view, and \code{FALSE} when it is obscured. } \details{ This is the \code{persp} method for the class \code{"im"}. The pixel image \code{x} must have real or integer values. These values are treated as heights of a surface, and the surface is displayed as a perspective plot on the current plot device, using equal scales on the \code{x} and \code{y} axes. The optional argument \code{colmap} gives an easy way to display different altitudes in different colours (if this is what you want). \itemize{ \item If \code{colmap} is a colour map (object of class \code{"colourmap"}, created by the function \code{\link{colourmap}}) then this colour map will be used to associate altitudes with colours. \item If \code{colmap} is a character vector, then the range of altitudes in the perspective plot will be divided into \code{length(colmap)} intervals, and those parts of the surface which lie in a particular altitude range will be assigned the corresponding colour from \code{colmap}. \item If \code{colmap} is a function in the \R language of the form \code{function(n, ...)}, this function will be called with an appropriate value of \code{n} to generate a character vector of \code{n} colours. Examples of such functions are \code{\link[grDevices]{heat.colors}}, \code{\link[grDevices]{terrain.colors}}, \code{\link[grDevices]{topo.colors}} and \code{\link[grDevices]{cm.colors}}. \item If \code{colmap} is a function in the \R language of the form \code{function(range, ...)} then it will be called with \code{range} equal to the range of altitudes, to determine the colour values or colour map. Examples of such functions are \code{\link{beachcolours}} and \code{\link{beachcolourmap}}. \item If \code{colmap} is a list with entries \code{breaks} and \code{col}, then \code{colmap$breaks} determines the breakpoints of the altitude intervals, and \code{colmap$col} provides the corresponding colours. } Alternatively, if the argument \code{colin} (\emph{colour input}) is present, then the colour map \code{colmap} will be applied to the pixel values of \code{colin} instead of the pixel values of \code{x}. The result is a perspective view of a surface with heights determined by \code{x} and colours determined by \code{colin} (mapped by \code{colmap}). If \code{apron=TRUE}, vertical surface is drawn around the boundary of the perspective plot, so that the terrain appears to have been cut out of a solid material. If colour data were supplied, then the apron is coloured light grey. Graphical parameters controlling the perspective plot are passed through the \code{...} arguments directly to the function \code{\link{persp.default}}. See the examples in \code{\link{persp.default}} or in \code{demo(persp)}. The vertical scale is controlled by the argument \code{expand}: setting \code{expand=1} will interpret the pixel values as being in the same units as the spatial coordinates \eqn{x} and \eqn{y} and represent them at the same scale. If \code{visible=TRUE}, the algorithm also computes whether each pixel in \code{x} is visible in the perspective view. In order to be visible, a pixel must not be obscured by another pixel which lies in front of it (as seen from the viewing direction), and the three-dimensional vector normal to the surface must be pointing toward the viewer. The return value of \code{persp.im} then has an attribute \code{"visible"} which is a pixel image, compatible with \code{x}, with pixel value equal to \code{TRUE} if the corresponding pixel in \code{x} is visible, and \code{FALSE} if it is not visible. } \seealso{ \code{\link{perspPoints}}, \code{\link{perspLines}} for drawing additional points or lines \emph{on the surface}. \code{\link[grDevices]{trans3d}} for mapping arbitrary \eqn{(x,y,z)} coordinate locations to the plotting coordinates. \code{\link{im.object}}, \code{\link{plot.im}}, \code{\link{contour.im}} } \examples{ # an image Z <- setcov(owin(), dimyx=32) persp(Z, colmap=terrain.colors(128)) if(interactive()) { co <- colourmap(range=c(0,1), col=rainbow(128)) persp(Z, colmap=co, axes=FALSE, shade=0.3) } ## Terrain elevation persp(bei.extra$elev, colmap=terrain.colors(128), apron=TRUE, theta=-30, phi=20, zlab="Elevation", main="", ticktype="detailed", expand=6) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/trim.rectangle.Rd0000644000176200001440000000252314611065351017027 0ustar liggesusers\name{trim.rectangle} \alias{trim.rectangle} \title{Cut margins from rectangle} \description{ Trims a margin from a rectangle. } \usage{ trim.rectangle(W, xmargin=0, ymargin=xmargin) } \arguments{ \item{W}{ A window (object of class \code{"owin"}). Must be of type \code{"rectangle"}. } \item{xmargin}{Width of horizontal margin to be trimmed. A single nonnegative number, or a vector of length 2 indicating margins of unequal width at left and right. } \item{ymargin}{Height of vertical margin to be trimmed. A single nonnegative number, or a vector of length 2 indicating margins of unequal width at bottom and top. } } \value{ Another object of class \code{"owin"} representing the window after margins are trimmed. } \details{ This is a simple convenience function to trim off a margin of specified width and height from each side of a rectangular window. Unequal margins can also be trimmed. } \seealso{ \code{\link{grow.rectangle}}, \code{\link{erosion}}, \code{\link{owin.object}} } \examples{ w <- square(10) # trim a margin of width 1 from all four sides square9 <- trim.rectangle(w, 1) # trim margin of width 3 from the right side # and margin of height 4 from top edge. v <- trim.rectangle(w, c(0,3), c(0,4)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/plot.quad.Rd0000644000176200001440000000424314611065347016026 0ustar liggesusers\name{plot.quad} \alias{plot.quad} \title{Plot a Spatial Quadrature Scheme} \description{ Plot a two-dimensional spatial quadrature scheme. } \usage{ \method{plot}{quad}(x, ..., main, add=FALSE, dum=list(), tiles=FALSE) } \arguments{ \item{x}{ The spatial quadrature scheme to be plotted. An object of class \code{"quad"}. } \item{\dots}{ extra arguments controlling the plotting of the data points of the quadrature scheme. } \item{main}{ text to be displayed as a title above the plot. } \item{add}{ Logical value indicating whether the graphics should be added to the current plot if there is one (\code{add=TRUE}) or whether a new plot should be initialised (\code{add=FALSE}, the default). } \item{dum}{ list of extra arguments controlling the plotting of the dummy points of the quadrature scheme. See below. } \item{tiles}{ Logical value indicating whether to display the tiles used to compute the quadrature weights. } } \value{ \code{NULL}. } \details{ This is the \code{plot} method for quadrature schemes (objects of class \code{"quad"}, see \code{\link{quad.object}}). First the data points of the quadrature scheme are plotted (in their observation window) using \code{\link{plot.ppp}} with any arguments specified in \code{...} Then the dummy points of the quadrature scheme are plotted using \code{\link{plot.ppp}} with any arguments specified in \code{dum}. By default the dummy points are superimposed onto the plot of data points. This can be overridden by including the argument \code{add=FALSE} in the list \code{dum} as shown in the examples. In this case the data and dummy point patterns are plotted separately. See \code{\link[graphics]{par}} and \code{\link{plot.ppp}} for other possible arguments controlling the plots. } \seealso{ \code{\link{quad.object}}, \code{\link{plot.ppp}}, \code{\link[graphics]{par}} } \examples{ Q <- quadscheme(nztrees) plot(Q, main="NZ trees: quadrature scheme") oldpar <- par(mfrow=c(2,1)) plot(Q, main="NZ trees", dum=list(add=FALSE)) par(oldpar) } \author{\adrian and \rolf } \keyword{spatial} \keyword{hplot} spatstat.geom/man/unstack.solist.Rd0000644000176200001440000000342114611065351017073 0ustar liggesusers\name{unstack.solist} \alias{unstack.solist} \alias{unstack.layered} \title{ Unstack Each Spatial Object in a List of Objects } \description{ Given a list of two-dimensional spatial objects, apply } \usage{ \method{unstack}{solist}(x, \dots) \method{unstack}{layered}(x, \dots) } \arguments{ \item{x}{ An object of class \code{"solist"} or \code{"layered"} representing a list of two-dimensional spatial objects. } \item{\dots}{ Ignored. } } \details{ The functions defined here are methods for the generic \code{\link[utils]{unstack}}. They expect the argument \code{x} to be a list of spatial objects, of class \code{"solist"} or \code{"layered"}. Each spatial object in the list \code{x} will be unstacked by applying the relevant method for \code{\link[utils]{unstack}}. This means that \itemize{ \item a marked point pattern with several columns of marks will be separated into several point patterns, each having a single column of marks \item a measure with \eqn{k}-dimensional vector values will be separated into \eqn{k} measures with scalar values } The resulting unstacked objects will be collected into a list of the same kind as \code{x}. Typically the length of \code{unstack(x)} is greater than the length of \code{x}. } \value{ A list belonging to the same class as \code{x}. } \author{ \spatstatAuthors. } \seealso{ \code{\link[utils]{unstack}} \code{\link[spatstat.model]{unstack.msr}}, \code{\link{unstack.ppp}}, \code{\link{unstack.psp}} } \examples{ A <- solist(finpines=finpines, cells=cells) A unstack(A) B <- layered(fin=finpines, loc=unmark(finpines), plotargs=list(list(), list(pch=16))) B plot(B) unstack(B) plot(unstack(B)) } \keyword{spatial} \keyword{manip} spatstat.geom/man/unstack.ppp.Rd0000644000176200001440000000351714611065351016363 0ustar liggesusers\name{unstack.ppp} \alias{unstack.ppp} \alias{unstack.psp} \alias{unstack.tess} \title{ Separate Multiple Columns of Marks } \description{ Given a spatial pattern with several columns of marks, take one column at a time, and return a list of spatial patterns each having only one column of marks. } \usage{ \method{unstack}{ppp}(x, \dots) \method{unstack}{psp}(x, \dots) \method{unstack}{tess}(x, \dots) } \arguments{ \item{x}{ A spatial point pattern (object of class \code{"ppp"}) or a spatial pattern of line segments (object of class \code{"psp"}) or a spatial tessellation (object of class \code{"tess"}). } \item{\dots}{ Ignored. } } \details{ The functions defined here are methods for the generic \code{\link[utils]{unstack}}. The functions expect a spatial object \code{x} which has several columns of marks; they separate the columns, and return a list of spatial objects, each having only one column of marks. If \code{x} has several columns of marks (i.e. \code{marks(x)} is a matrix, data frame or hyperframe with several columns), then \code{y <- unstack(x)} is a list of spatial objects, each of the same kind as \code{x}. The \code{j}th entry \code{y[[j]]} is equivalent to \code{x} except that it only includes the \code{j}th column of \code{marks(x)}. If \code{x} has no marks, or has only a single column of marks, the result is a list consisting of one entry, which is \code{x}. } \value{ A list, of class \code{"solist"}, whose entries are objects of the same type as \code{x}. } \author{ \spatstatAuthors. } \seealso{ \code{\link[utils]{unstack}} \code{\link[spatstat.model]{unstack.msr}} See also methods for the generic \code{\link[base]{split}} such as \code{\link{split.ppp}}. } \examples{ finpines unstack(finpines) } \keyword{spatial} \keyword{manip} spatstat.geom/man/discretise.Rd0000644000176200001440000000703314643111575016255 0ustar liggesusers\name{discretise} \alias{discretise} \title{ Safely Convert Point Pattern Window to Binary Mask } \description{ Given a point pattern, discretise its window by converting it to a binary pixel mask, adjusting the mask so that it still contains all the points. Optionally discretise the point locations as well, by moving them to the nearest pixel centres. } \usage{ discretise(X, eps = NULL, dimyx = NULL, xy = NULL, move.points=FALSE, rule.eps=c("adjust.eps", "grow.frame", "shrink.frame")) } \arguments{ \item{X}{A point pattern (object of class \code{"ppp"}) to be converted.} \item{eps}{(optional) width and height of each pixel} \item{dimyx}{(optional) pixel array dimensions} \item{xy}{(optional) pixel coordinates} \item{move.points}{Logical value specifying whether the points should also be discretised by moving each point to the nearest pixel centre.} \item{rule.eps}{ Argument passed to \code{\link[spatstat.geom]{as.mask}} controlling the discretisation. } } \details{ This function modifies the point pattern \code{X} by converting its observation window \code{Window(X)} to a binary pixel image (a window of type \code{"mask"}). It ensures that no points of \code{X} are deleted by the discretisation. If \code{move.points=TRUE}, the point coordinates are also discretised. The window is first discretised using \code{\link[spatstat.geom]{as.mask}}. Next, \itemize{ \item If \code{move.points=TRUE}, each point of \code{X} is moved to the centre of the nearest pixel inside the discretised window. \item If \code{move.points=FALSE} (the default), the point coordinates are unchanged. It can happen that points of \code{X} that were inside the original window may fall outside the new mask. The \code{discretise} function corrects this by augmenting the mask (so that the mask includes any pixel that contains a point of the pattern). } The arguments \code{eps}, \code{dimyx}, \code{xy} and \code{rule.eps} control the fineness of the pixel array. They are passed to \code{\link[spatstat.geom]{as.mask}}. If \code{eps}, \code{dimyx} and \code{xy} are all absent or \code{NULL}, and if the window of \code{X} is of type \code{"mask"} to start with, then \code{discretise(X)} returns \code{X} unchanged. See \code{\link[spatstat.geom]{as.mask}} for further details about the arguments \code{eps}, \code{dimyx}, \code{xy} and \code{rule.eps}, and the process of converting a window to one of type \code{mask}. } \section{Error checking}{ Before doing anything, \code{discretise} checks that all the points of the pattern are actually inside the original window. This is guaranteed to be the case if the pattern was constructed using \code{\link{ppp}} or \code{\link{as.ppp}}. However anomalies are possible if the point pattern was created or manipulated inappropriately. These will cause an error. } \value{ A point pattern (object of class \code{"ppp"}). } \author{ \adrian and \rolf } \seealso{ \code{\link[spatstat.geom]{as.mask}} } \examples{ X <- demopat plot(X, main="original pattern") Y <- discretise(X, dimyx=50) plot(Y, main="discretise(X)") stopifnot(npoints(X) == npoints(Y)) # what happens if we just convert the window to a mask? W <- Window(X) M <- as.mask(W, dimyx=50) plot(M, main="window of X converted to mask") plot(X, add=TRUE, pch=16) plot(X[M], add=TRUE, pch=1, cex=1.5) XM <- X[M] cat(paste(npoints(X) - npoints(XM), "points of X lie outside M\n")) } \keyword{spatial} \keyword{manip} spatstat.geom/man/bdist.tiles.Rd0000644000176200001440000000206214611065345016336 0ustar liggesusers\name{bdist.tiles} \alias{bdist.tiles} \title{Distance to Boundary of Window} \description{ Computes the shortest distances from each tile in a tessellation to the boundary of the window. } \usage{ bdist.tiles(X) } \arguments{ \item{X}{A tessellation (object of class \code{"tess"}).} } \value{ A numeric vector, giving the shortest distance from each tile in the tessellation to the boundary of the window. Entries of the vector correspond to the entries of \code{tiles(X)}. } \details{ This function computes, for each tile \eqn{s_i}{s[[i]]} in the tessellation \code{X}, the shortest distance from \eqn{s_i}{s[[i]]} to the boundary of the window \eqn{W} containing the tessellation. } \seealso{ \code{\link{tess}}, \code{\link{bdist.points}}, \code{\link{bdist.pixels}} } \examples{ P <- runifrect(15) X <- dirichlet(P) plot(X, col="red") B <- bdist.tiles(X) # identify tiles that do not touch the boundary plot(X[B > 0], add=TRUE, col="green", lwd=3) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/as.polygonal.Rd0000644000176200001440000000362014643111575016523 0ustar liggesusers\name{as.polygonal} \Rdversion{1.1} \alias{as.polygonal} \title{ Convert a Window to a Polygonal Window } \description{ Given a window \code{W} of any geometric type (rectangular, polygonal or binary mask), this function returns a polygonal window that represents the same spatial domain. } \usage{ as.polygonal(W, repair=FALSE) } \arguments{ \item{W}{ A window (object of class \code{"owin"}). } \item{repair}{ Logical value indicating whether to check the validity of the polygon data and repair it, if \code{W} is already a polygonal window. } } \details{ Given a window \code{W} of any geometric type (rectangular, polygonal or binary mask), this function returns a polygonal window that represents the same spatial domain. If \code{W} is a rectangle, it is converted to a polygon with 4 vertices. If \code{W} is already polygonal, it is returned unchanged, by default. However if \code{repair=TRUE} then the validity of the polygonal coordinates will be checked (for example to check the boundary is not self-intersecting) and repaired if necessary, so that the result could be different from \code{W}. If \code{W} is a binary mask, then each pixel in the mask is replaced by a small square or rectangle, and the union of these squares or rectangles is computed. The result is a polygonal window that has only horizontal and vertical edges. (Use \code{\link{simplify.owin}} to remove the staircase appearance, if desired). } \value{ A polygonal window (object of class \code{"owin"} and of type \code{"polygonal"}). } \author{ \spatstatAuthors } \seealso{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link[spatstat.geom]{as.mask}}, \code{\link{simplify.owin}} } \examples{ m <- as.mask(letterR, dimyx=32) p <- as.polygonal(m) if(interactive()) { plot(m) plot(p, add=TRUE, lwd=2) } } \keyword{spatial} \keyword{manip} spatstat.geom/man/rgbim.Rd0000644000176200001440000000462014611065350015210 0ustar liggesusers\name{rgbim} \alias{rgbim} \alias{hsvim} \title{Create Colour-Valued Pixel Image} \description{ Creates an object of class \code{"im"} representing a two-dimensional pixel image whose pixel values are colours. } \usage{ rgbim(R, G, B, A, maxColorValue=255, autoscale=FALSE) hsvim(H, S, V, A, autoscale=FALSE) } \arguments{ \item{R,G,B}{ Pixel images (objects of class \code{"im"}) or constants giving the red, green, and blue components of a colour, respectively. } \item{A}{ Optional. Pixel image or constant value giving the alpha (transparency) component of a colour. } \item{maxColorValue}{ Maximum colour channel value for \code{R,G,B,A}. } \item{H,S,V}{ Pixel images (objects of class \code{"im"}) or constants giving the hue, saturation, and value components of a colour, respectively. } \item{autoscale}{ Logical. If \code{TRUE}, input values are automatically rescaled to fit the permitted range. RGB values are scaled to lie between 0 and \code{maxColorValue}. HSV values are scaled to lie between 0 and 1. } } \details{ These functions take three pixel images, with real or integer pixel values, and create a single pixel image whose pixel values are colours recognisable to \R. Some of the arguments may be constant numeric values, but at least one of the arguments must be a pixel image. The image arguments should be compatible (in array dimension and in spatial position). \code{rgbim} calls \code{\link{rgb}} to compute the colours, while \code{hsvim} calls \code{\link{hsv}}. See the help for the relevant function for more information about the meaning of the colour channels. } \seealso{ \code{\link{im.object}}, \code{\link{rgb}}, \code{\link{hsv}}. See \code{\link[spatstat.geom:colourtools]{colourtools}} for additional colour tools. } \examples{ \testonly{ op <- spatstat.options(npixel=32) } # create three images with values in [0,1] X <- setcov(owin()) X <- eval.im(pmin(1,X)) M <- Window(X) Y <- as.im(function(x,y){(x+1)/2}, W=M) Z <- as.im(function(x,y){(y+1)/2}, W=M) # convert RGB <- rgbim(X, Y, Z, maxColorValue=1) HSV <- hsvim(X, Y, Z) opa <- par(mfrow=c(1,2)) plot(RGB, valuesAreColours=TRUE) plot(HSV, valuesAreColours=TRUE) par(opa) \testonly{ spatstat.options(op) } } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} \keyword{datagen} spatstat.geom/man/shift.Rd0000644000176200001440000000170414611065350015225 0ustar liggesusers\name{shift} \alias{shift} \title{Apply Vector Translation} \description{ Applies a vector shift of the plane to a geometrical object, such as a point pattern or a window. } \usage{ shift(X, \dots) } \arguments{ \item{X}{Any suitable dataset representing a two-dimensional object, such as a point pattern (object of class \code{"ppp"}), or a window (object of class \code{"owin"}).} \item{\dots}{Arguments determining the shift vector.} } \value{ Another object of the same type, representing the result of applying the shift. } \details{ This is generic. Methods are provided for point patterns (\code{\link{shift.ppp}}) and windows (\code{\link{shift.owin}}). The object is translated by the vector \code{vec}. } \seealso{ \code{\link{shift.ppp}}, \code{\link{shift.owin}}, \code{\link{rotate}}, \code{\link{affine}}, \code{\link{periodify}} } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/dilated.areas.Rd0000644000176200001440000000441314611065346016615 0ustar liggesusers\name{dilated.areas} \Rdversion{1.1} \alias{dilated.areas} \title{ Areas of Morphological Dilations } \description{ Computes the areas of successive morphological dilations. } \usage{ dilated.areas(X, r, W=as.owin(X), ..., constrained=TRUE, exact = FALSE) } \arguments{ \item{X}{ Object to be dilated. A point pattern (object of class \code{"ppp"}), a line segment pattern (object of class \code{"psp"}), or a window (object of class \code{"owin"}). } \item{r}{ Numeric vector of radii for the dilations. } \item{W}{ Window (object of class \code{"owin"}) inside which the areas will be computed, if \code{constrained=TRUE}. } \item{\dots}{ Arguments passed to \code{\link{distmap}} to control the pixel resolution, if \code{exact=FALSE}. } \item{constrained}{ Logical flag indicating whether areas should be restricted to the window \code{W}. } \item{exact}{ Logical flag indicating whether areas should be computed using analytic geometry (which is slower but more accurate). Currently available only when \code{X} is a point pattern. } } \details{ This function computes the areas of the dilations of \code{X} by each of the radii \code{r[i]}. Areas may also be computed inside a specified window \code{W}. The morphological dilation of a set \eqn{X} by a distance \eqn{r > 0} is the subset consisting of all points \eqn{x}{x} such that the distance from \eqn{x} to \eqn{X} is less than or equal to \eqn{r}. When \code{X} is a point pattern, the dilation by a distance \eqn{r} is the union of discs of radius \eqn{r} centred at the points of \code{X}. The argument \code{r} should be a vector of nonnegative numbers. If \code{exact=TRUE} and if \code{X} is a point pattern, then the areas are computed using analytic geometry, which is slower but much more accurate. Otherwise the computation is performed using \code{\link{distmap}}. To compute the dilated object itself, use \code{\link{dilation}}. } \seealso{ \code{\link{owin}}, \code{\link{as.owin}}, \code{\link{dilation}}, \code{\link{eroded.areas}} } \examples{ X <- runifrect(10) a <- dilated.areas(X, c(0.1,0.2), W=square(1), exact=TRUE) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/quadscheme.Rd0000644000176200001440000001662414611065350016236 0ustar liggesusers\name{quadscheme} \alias{quadscheme} \title{Generate a Quadrature Scheme from a Point Pattern} \description{ Generates a quadrature scheme (an object of class \code{"quad"}) from point patterns of data and dummy points. } \usage{ quadscheme(data, dummy, method="grid", \dots) } \arguments{ \item{data}{ The observed data point pattern. An object of class \code{"ppp"} or in a format recognised by \code{\link{as.ppp}()} } \item{dummy}{ The pattern of dummy points for the quadrature. An object of class \code{"ppp"} or in a format recognised by \code{\link{as.ppp}()} Defaults to \code{default.dummy(data, ...)} } \item{method}{ The name of the method for calculating quadrature weights: either \code{"grid"} or \code{"dirichlet"}. } \item{\dots}{ Parameters of the weighting method (see below) and parameters for constructing the dummy points if necessary. } } \value{ An object of class \code{"quad"} describing the quadrature scheme (data points, dummy points, and quadrature weights) suitable as the argument \code{Q} of the function \code{\link[spatstat.model]{ppm}()} for fitting a point process model. The quadrature scheme can be inspected using the \code{print} and \code{plot} methods for objects of class \code{"quad"}. } \details{ This is the primary method for producing a quadrature schemes for use by \code{\link[spatstat.model]{ppm}}. The function \code{\link[spatstat.model]{ppm}} fits a point process model to an observed point pattern using the Berman-Turner quadrature approximation (Berman and Turner, 1992; Baddeley and Turner, 2000) to the pseudolikelihood of the model. It requires a quadrature scheme consisting of the original data point pattern, an additional pattern of dummy points, and a vector of quadrature weights for all these points. Such quadrature schemes are represented by objects of class \code{"quad"}. See \code{\link{quad.object}} for a description of this class. Quadrature schemes are created by the function \code{quadscheme}. The arguments \code{data} and \code{dummy} specify the data and dummy points, respectively. There is a sensible default for the dummy points (provided by \code{\link{default.dummy}}). Alternatively the dummy points may be specified arbitrarily and given in any format recognised by \code{\link{as.ppp}}. There are also functions for creating dummy patterns including \code{\link{corners}}, \code{\link{gridcentres}}, \code{\link{stratrand}} and \code{\link{spokes}}. The quadrature region is the region over which we are integrating, and approximating integrals by finite sums. If \code{dummy} is a point pattern object (class \code{"ppp"}) then the quadrature region is taken to be \code{Window(dummy)}. If \code{dummy} is just a list of \eqn{x, y} coordinates then the quadrature region defaults to the observation window of the data pattern, \code{Window(data)}. If \code{dummy} is missing, then a pattern of dummy points will be generated using \code{\link{default.dummy}}, taking account of the optional arguments \code{...}. By default, the dummy points are arranged in a rectangular grid; recognised arguments include \code{nd} (the number of grid points in the horizontal and vertical directions) and \code{eps} (the spacing between dummy points). If \code{random=TRUE}, a systematic random pattern of dummy points is generated instead. See \code{\link{default.dummy}} for details. If \code{method = "grid"} then the optional arguments (for \code{\dots}) are \code{(nd, ntile, eps)}. The quadrature region (defined above) is divided into an \code{ntile[1]} by \code{ntile[2]} grid of rectangular tiles. The weight for each quadrature point is the area of a tile divided by the number of quadrature points in that tile. If \code{method="dirichlet"} then the optional arguments are \code{(exact=TRUE, nd, eps)}. The quadrature points (both data and dummy) are used to construct the Dirichlet tessellation. The quadrature weight of each point is the area of its Dirichlet tile inside the quadrature region. If \code{exact == TRUE} then this area is computed exactly using the package \code{deldir}; otherwise it is computed approximately by discretisation. } \section{Error Messages}{ The following error messages need some explanation. (See also the list of error messages in \code{\link[spatstat.model]{ppm.ppp}}). \describe{ \item{\dQuote{Some tiles with positive area do not contain any quadrature points: relative error = X\%}}{ This is not important unless the relative error is large. In the default rule for computing the quadrature weights, space is divided into rectangular tiles, and the number of quadrature points (data and dummy points) in each tile is counted. It is possible for a tile with non-zero area to contain no quadrature points; in this case, the quadrature scheme will contribute a bias to the model-fitting procedure. \bold{A small relative error (less than 2 percent) is not important.} Relative errors of a few percent can occur because of the shape of the window. If the relative error is greater than about 5 percent, we recommend trying different parameters for the quadrature scheme, perhaps setting a larger value of \code{nd} to increase the number of dummy points. A relative error greater than 10 percent indicates a major problem with the input data. The quadrature scheme should be inspected by plotting and printing it. (The most likely cause of this problem is that the spatial coordinates of the original data were not handled correctly, for example, coordinates of the locations and the window boundary were incompatible.) } \item{\dQuote{Some tiles with zero area contain quadrature points}}{ This error message is rare, and has no consequences. It is mainly of interest to programmers. It occurs when the area of a tile is calculated to be equal to zero, but a quadrature point has been placed in the tile. } } } \references{ Baddeley, A. and Turner, R. Practical maximum pseudolikelihood for spatial point patterns. \emph{Australian and New Zealand Journal of Statistics} \bold{42} (2000) 283--322. Berman, M. and Turner, T.R. Approximating point process likelihoods with GLIM. \emph{Applied Statistics} \bold{41} (1992) 31--38. } \seealso{ \code{\link[spatstat.model]{ppm}}, \code{\link{as.ppp}}, \code{\link{quad.object}}, \code{\link{gridweights}}, \code{\link{dirichletWeights}}, \code{\link{corners}}, \code{\link{gridcentres}}, \code{\link{stratrand}}, \code{\link{spokes}} } \examples{ # grid weights Q <- quadscheme(simdat) Q <- quadscheme(simdat, method="grid") Q <- quadscheme(simdat, eps=0.5) # dummy point spacing 0.5 units Q <- quadscheme(simdat, nd=50) # 1 dummy point per tile Q <- quadscheme(simdat, ntile=25, nd=50) # 4 dummy points per tile # Dirichlet weights Q <- quadscheme(simdat, method="dirichlet", exact=FALSE) # random dummy pattern # D <- runifrect(250, Window(simdat)) # Q <- quadscheme(simdat, D, method="dirichlet", exact=FALSE) # polygonal window data(demopat) X <- unmark(demopat) Q <- quadscheme(X) # mask window Window(X) <- as.mask(Window(X)) Q <- quadscheme(X) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/unitname.Rd0000644000176200001440000000576214650323103015734 0ustar liggesusers\name{unitname} \alias{unitname} \alias{unitname.im} \alias{unitname.owin} \alias{unitname.ppp} \alias{unitname.psp} \alias{unitname.quad} \alias{unitname.tess} \alias{unitname<-} \alias{unitname<-.im} \alias{unitname<-.owin} \alias{unitname<-.ppp} \alias{unitname<-.psp} \alias{unitname<-.quad} \alias{unitname<-.tess} \title{Name for Unit of Length} \description{ Inspect or change the name of the unit of length in a spatial dataset. } \usage{ unitname(x) unitname(x) <- value \method{unitname}{im}(x) \method{unitname}{owin}(x) \method{unitname}{ppp}(x) \method{unitname}{psp}(x) \method{unitname}{quad}(x) \method{unitname}{tess}(x) \method{unitname}{im}(x) <- value \method{unitname}{owin}(x) <- value \method{unitname}{ppp}(x) <- value \method{unitname}{psp}(x) <- value \method{unitname}{quad}(x) <- value \method{unitname}{tess}(x) <- value } \arguments{ \item{x}{A spatial dataset. Either a point pattern (object of class \code{"ppp"}), a line segment pattern (object of class \code{"psp"}), a window (object of class \code{"owin"}), a pixel image (object of class \code{"im"}), a tessellation (object of class \code{"tess"}), a quadrature scheme (object of class \code{"quad"}), or a fitted point process model (object of class \code{"ppm"} or \code{"kppm"} or \code{"slrm"} or \code{"dppm"} or \code{"minconfit"}). } \item{value}{ Name of the unit of length. See Details. } } \details{ Spatial datasets in the \pkg{spatstat} package may include the name of the unit of length. This name is used when printing or plotting the dataset, and in some other applications. \code{unitname(x)} extracts this name, and \code{unitname(x) <- value} sets the name to \code{value}. A valid name is either \itemize{ \item a single character string \item a vector of two character strings giving the singular and plural forms of the unit name \item a list of length 3, containing two character strings giving the singular and plural forms of the basic unit, and a number specifying the multiple of this unit. } Note that re-setting the name of the unit of length \emph{does not} affect the numerical values in \code{x}. It changes only the string containing the name of the unit of length. To rescale the numerical values, use \code{\link[spatstat.geom]{rescale}}. } \value{ The return value of \code{unitname} is an object of class \code{"unitname"} containing the name of the unit of length in \code{x}. There are methods for \code{print}, \code{summary}, \code{as.character}, \code{\link[spatstat.geom]{rescale}} and \code{\link[spatstat.geom]{compatible}}. } \author{ \spatstatAuthors. } \seealso{ \code{\link[spatstat.geom]{rescale}}, \code{\link[spatstat.geom]{owin}}, \code{\link[spatstat.geom]{ppp}} } \examples{ X <- runifrect(20) # if the unit of length is 1 metre: unitname(X) <- c("metre", "metres") # if the unit of length is 6 inches: unitname(X) <- list("inch", "inches", 6) } \keyword{spatial} \keyword{manip} spatstat.geom/man/plot.solist.Rd0000644000176200001440000002153514721742045016413 0ustar liggesusers\name{plot.solist} \alias{plot.solist} \title{Plot a List of Spatial Objects} \description{ Plots a list of two-dimensional spatial objects. } \usage{ \method{plot}{solist}(x, \dots, main, arrange=TRUE, nrows=NULL, ncols=NULL, main.panel=NULL, mar.panel=c(2,1,1,2), hsep=0, vsep=0, panel.begin=NULL, panel.end=NULL, panel.args=NULL, panel.begin.args=NULL, panel.end.args=NULL, panel.vpad = 0.2, plotcommand="plot", adorn.left=NULL, adorn.right=NULL, adorn.top=NULL, adorn.bottom=NULL, adorn.size=0.2, adorn.args=list(), equal.scales=FALSE, halign=FALSE, valign=FALSE) } \arguments{ \item{x}{ An object of the class \code{"solist"}, essentially a list of two-dimensional spatial datasets. } \item{\dots}{ Arguments passed to \code{\link{plot}} when generating each plot panel. } \item{main}{ Overall heading for the plot. } \item{arrange}{ Logical flag indicating whether to plot the objects side-by-side on a single page (\code{arrange=TRUE}) or plot them individually in a succession of frames (\code{arrange=FALSE}). } \item{nrows,ncols}{ Optional. The number of rows/columns in the plot layout (assuming \code{arrange=TRUE}). You can specify either or both of these numbers. } \item{main.panel}{ Optional. A character string, or a vector of character strings, or a vector of expressions, giving the headings for each plot panel. } \item{mar.panel}{ Size of the margins outside each plot panel. A numeric vector of length 4 giving the bottom, left, top, and right margins in that order. (Alternatively the vector may have length 1 or 2 and will be replicated to length 4). See the section on \emph{Spacing between plots}. } \item{hsep,vsep}{ Additional horizontal and vertical separation between plot panels, expressed in the same units as \code{mar.panel}. } \item{panel.begin,panel.end}{ Optional. Functions that will be executed before and after each panel is plotted. See Details. } \item{panel.args}{ Optional. Function that determines different plot arguments for different panels. See Details. } \item{panel.begin.args}{ Optional. List of additional arguments for \code{panel.begin} when it is a function. } \item{panel.end.args}{ Optional. List of additional arguments for \code{panel.end} when it is a function. } \item{panel.vpad}{ Amount of extra vertical space that should be allowed for the title of each panel, if a title will be displayed. Expressed as a fraction of the height of the panel. Applies only when \code{equal.scales=FALSE} (the default). } \item{plotcommand}{ Optional. Character string containing the name of the command that should be executed to plot each panel. } \item{adorn.left,adorn.right,adorn.top,adorn.bottom}{ Optional. Functions (with no arguments) that will be executed to generate additional plots at the margins (left, right, top and/or bottom, respectively) of the array of plots. Alternatively they may be objects of class \code{"colourmap"} or \code{"symbolmap"}. } \item{adorn.size}{ Relative width (as a fraction of the other panels' widths) of the margin plots. } \item{adorn.args}{ Optional list of arguments passed to the functions \code{adorn.left}, \code{adorn.right}, \code{adorn.top} and \code{adorn.bottom} if they are functions, or arguments passed to \code{\link{plot.colourmap}} or \code{\link{plot.symbolmap}} as appropriate. } \item{equal.scales}{ Logical value indicating whether the components should be plotted at (approximately) the same physical scale. } \item{halign,valign}{ Logical values indicating whether panels in a column should be aligned to the same \eqn{x} coordinate system (\code{halign=TRUE}) and whether panels in a row should be aligned to the same \eqn{y} coordinate system (\code{valign=TRUE}). These are applicable only if \code{equal.scales=TRUE}. } } \value{ Null. } \details{ This is the \code{plot} method for the class \code{"solist"}. An object of class \code{"solist"} represents a list of two-dimensional spatial datasets. This is the \code{plot} method for such objects. In the \pkg{spatstat} package, various functions produce an object of class \code{"solist"}. These objects can be plotted in a nice arrangement using \code{plot.solist}. See the Examples. The argument \code{panel.args} determines extra graphics parameters for each panel. It should be a function that will be called as \code{panel.args(i)} where \code{i} is the panel number. Its return value should be a list of graphics parameters that can be passed to the relevant \code{plot} method. These parameters override any parameters specified in the \code{\dots} arguments. The arguments \code{panel.begin} and \code{panel.end} determine graphics that will be plotted before and after each panel is plotted. They may be objects of some class that can be plotted with the generic \code{plot} command. Alternatively they may be functions that will be called as \code{panel.begin(i, y, main=main.panel[i])} and \code{panel.end(i, y, add=TRUE)} where \code{i} is the panel number and \code{y = x[[i]]}. If all entries of \code{x} are pixel images, the function \code{\link{image.listof}} is called to control the plotting. The arguments \code{equal.ribbon} and \code{col} can be used to determine the colour map or maps applied. If \code{equal.scales=FALSE} (the default), then the plot panels will have equal height on the plot device (unless there is only one column of panels, in which case they will have equal width on the plot device). This means that the objects are plotted at different physical scales, by default. If \code{equal.scales=TRUE}, then the dimensions of the plot panels on the plot device will be proportional to the spatial dimensions of the corresponding components of \code{x}. This means that the objects will be plotted at \emph{approximately} equal physical scales. If these objects have very different spatial sizes, the plot command could fail (when it tries to plot the smaller objects at a tiny scale), with an error message that the figure margins are too large. The objects will be plotted at \emph{exactly} equal physical scales, and \emph{exactly} aligned on the device, under the following conditions: \itemize{ \item every component of \code{x} is a spatial object whose position can be shifted by \code{\link{shift}}; \item \code{panel.begin} and \code{panel.end} are either \code{NULL} or they are spatial objects whose position can be shifted by \code{\link{shift}}; \item \code{adorn.left}, \code{adorn.right}, \code{adorn.top} and \code{adorn.bottom} are all \code{NULL}. } Another special case is when every component of \code{x} is an object of class \code{"fv"} representing a function. If \code{equal.scales=TRUE} then all these functions will be plotted with the same axis scales (i.e. with the same \code{xlim} and the same \code{ylim}). } \section{Spacing between plots}{ The spacing between individual plots is controlled by the parameters \code{mar.panel}, \code{hsep} and \code{vsep}. If \code{equal.scales=FALSE}, the plot panels are logically separate plots. The margins for each panel are determined by the argument \code{mar.panel} which becomes the graphics parameter \code{mar} described in the help file for \code{\link{par}}. One unit of \code{mar} corresponds to one line of text in the margin. If \code{hsep} or \code{vsep} are present, \code{mar.panel} is augmented by \code{c(vsep, hsep, vsep, hsep)/2}. If \code{equal.scales=TRUE}, all the plot panels are drawn in the same coordinate system which represents a physical scale. The unit of measurement for \code{mar.panel[1,3]} is one-sixth of the greatest height of any object plotted in the same row of panels, and the unit for \code{mar.panel[2,4]} is one-sixth of the greatest width of any object plotted in the same column of panels. If \code{hsep} or \code{vsep} are present, they are interpreted in the same units as \code{mar.panel[2]} and \code{mar.panel[1]} respectively. } \seealso{ \code{\link{plot.anylist}}, \code{\link{contour.listof}}, \code{\link{image.listof}}, \code{\link[spatstat.explore]{density.splitppp}} } \section{Error messages}{ If the error message \sQuote{Figure margins too large} occurs, this generally means that one of the objects had a much smaller physical scale than the others. Ensure that \code{equal.scales=FALSE} and increase the values of \code{mar.panel}. } \examples{ D <- solapply(split(amacrine), distmap) plot(D) plot(D, main="", equal.ribbon=TRUE, panel.end=function(i,y,...){contour(y, ...)}) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{hplot} spatstat.geom/man/duplicated.ppp.Rd0000644000176200001440000000550314611065346017032 0ustar liggesusers\name{duplicated.ppp} \alias{duplicated.ppp} \alias{duplicated.ppx} \alias{anyDuplicated.ppp} \alias{anyDuplicated.ppx} \title{Determine Duplicated Points in a Spatial Point Pattern} \description{ Determines which points in a spatial point pattern are duplicates of previous points, and returns a logical vector. } \usage{ \method{duplicated}{ppp}(x, \dots, rule=c("spatstat", "deldir", "unmark")) \method{duplicated}{ppx}(x, \dots) \method{anyDuplicated}{ppp}(x, \dots) \method{anyDuplicated}{ppx}(x, \dots) } \arguments{ \item{x}{ A spatial point pattern (object of class \code{"ppp"} or \code{"ppx"}). } \item{\dots}{ Ignored. } \item{rule}{ Character string. The rule for determining duplicated points. } } \value{ \code{duplicated(x)} returns a logical vector of length equal to the number of points in \code{x}. \code{anyDuplicated(x)} is a number equal to 0 if there are no duplicated points, and otherwise is equal to the index of the first duplicated point. } \details{ These are methods for the generic functions \code{\link{duplicated}} and \code{\link{anyDuplicated}} for point pattern datasets (of class \code{"ppp"}, see \code{\link{ppp.object}}, or class \code{"ppx"}). \code{anyDuplicated(x)} is a faster version of \code{any(duplicated(x))}. Two points in a point pattern are deemed to be identical if their \eqn{x,y} coordinates are the same, and their marks are also the same (if they carry marks). The Examples section illustrates how it is possible for a point pattern to contain a pair of identical points. This function determines which points in \code{x} duplicate other points that appeared earlier in the sequence. It returns a logical vector with entries that are \code{TRUE} for duplicated points and \code{FALSE} for unique (non-duplicated) points. If \code{rule="spatstat"} (the default), two points are deemed identical if their coordinates are equal according to \code{==}, \emph{and} their marks are equal according to \code{==}. This is the most stringent possible test. If \code{rule="unmark"}, duplicated points are determined by testing equality of their coordinates only, using \code{==}. If \code{rule="deldir"}, duplicated points are determined by testing equality of their coordinates only, using the function \code{\link[deldir]{duplicatedxy}} in the package \pkg{deldir}, which currently uses \code{\link{duplicated.data.frame}}. Setting \code{rule="deldir"} will ensure consistency with functions in the \pkg{deldir} package. } \seealso{ \code{\link{ppp.object}}, \code{\link{unique.ppp}}, \code{\link{multiplicity.ppp}} } \examples{ X <- ppp(c(1,1,0.5), c(2,2,1), window=square(3)) duplicated(X) duplicated(X, rule="deldir") } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/padimage.Rd0000644000176200001440000000320514611065347015663 0ustar liggesusers\name{padimage} \alias{padimage} \title{ Pad the Border of a Pixel Image } \description{ Fills the border of a pixel image with a given value or values, or extends a pixel image to fill a larger window. } \usage{ padimage(X, value=NA, n=1, W=NULL) } \arguments{ \item{X}{ Pixel image (object of class \code{"im"}). } \item{value}{ Single value to be placed around the border of \code{X}. } \item{n}{ Width of border, in pixels. See Details. } \item{W}{ Window for the resulting image. Incompatible with \code{n}. } } \details{ The image \code{X} will be expanded by a margin of \code{n} pixels, or extended to fill the window \code{W}, with new pixel values set to \code{value}. The argument \code{value} should be a single value (a vector of length 1), normally a value of the same type as the pixel values of \code{X}. It may be \code{NA}. Alternatively if \code{X} is a factor-valued image, \code{value} can be one of the levels of \code{X}. If \code{n} is given, it may be a single number, specifying the width of the border in pixels. Alternatively it may be a vector of length 2 or 4. It will be replicated to length 4, and these numbers will be interpreted as the border widths for the (left, right, top, bottom) margins respectively. Alternatively if \code{W} is given, the image will be extended to the window \code{W}. } \value{ Another object of class \code{"im"}, of the same type as \code{X}. } \author{\adrian \rolf and \ege } \seealso{ \code{\link{im}} } \examples{ Z <- setcov(owin()) plot(padimage(Z, 1, 10)) } \keyword{spatial} \keyword{manip} spatstat.geom/man/centroid.owin.Rd0000644000176200001440000000363614611065345016704 0ustar liggesusers\name{centroid.owin} \alias{centroid.owin} \title{Centroid of a window} \description{ Computes the centroid (centre of mass) of a window } \usage{ centroid.owin(w, as.ppp = FALSE) } \arguments{ \item{w}{A window} \item{as.ppp}{Logical flag indicating whether to return the centroid as a point pattern (\code{ppp} object)} } \value{ Either a list with components \code{x, y}, or a point pattern (of class \code{ppp}) consisting of a single point, giving the coordinates of the centroid of the window \code{w}. } \details{ The centroid of the window \code{w} is computed. The centroid (``centre of mass'') is the point whose \eqn{x} and \eqn{y} coordinates are the mean values of the \eqn{x} and \eqn{y} coordinates of all points in the window. The argument \code{w} should be a window (an object of class \code{"owin"}, see \code{\link{owin.object}} for details) or can be given in any format acceptable to \code{\link{as.owin}()}. The calculation uses an exact analytic formula for the case of polygonal windows. Note that the centroid of a window is not necessarily inside the window, unless the window is convex. If \code{as.ppp=TRUE} and the centroid of \code{w} lies outside \code{w}, then the window of the returned point pattern will be a rectangle containing the original window (using \code{\link{as.rectangle}}. } \seealso{ \code{\link{owin}}, \code{\link{as.owin}} } \examples{ w <- owin(c(0,1),c(0,1)) centroid.owin(w) # returns 0.5, 0.5 w <- Window(demopat) # an irregular window cent <- centroid.owin(w, as.ppp = TRUE) wapprox <- as.mask(w) # pixel approximation of window if(interactive()) { plot(cent) # plot the window and its centroid points(centroid.owin(wapprox)) # should be indistinguishable } \testonly{ centroid.owin(w) centroid.owin(wapprox) } } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/by.im.Rd0000644000176200001440000000325614611065345015136 0ustar liggesusers\name{by.im} \alias{by.im} \title{Apply Function to Image Broken Down by Factor} \description{ Splits a pixel image into sub-images and applies a function to each sub-image. } \usage{ \method{by}{im}(data, INDICES, FUN, ...) } \arguments{ \item{data}{A pixel image (object of class \code{"im"}).} \item{INDICES}{Grouping variable. Either a tessellation (object of class \code{"tess"}) or a factor-valued pixel image. } \item{FUN}{Function to be applied to each sub-image of \code{data}.} \item{\dots}{Extra arguments passed to \code{FUN}.} } \details{ This is a method for the generic function \code{\link{by}} for pixel images (class \code{"im"}). The pixel image \code{data} is first divided into sub-images according to \code{INDICES}. Then the function \code{FUN} is applied to each subset. The results of each computation are returned in a list. The grouping variable \code{INDICES} may be either \itemize{ \item a tessellation (object of class \code{"tess"}). Each tile of the tessellation delineates a subset of the spatial domain. \item a pixel image (object of class \code{"im"}) with factor values. The levels of the factor determine subsets of the spatial domain. } } \value{ A list containing the results of each evaluation of \code{FUN}. } \seealso{ \code{\link{split.im}}, \code{\link{tess}}, \code{\link{im}} } \examples{ W <- square(1) X <- as.im(function(x,y){sqrt(x^2+y^2)}, W) Y <- dirichlet(runifrect(12, W)) # mean pixel value in each subset unlist(by(X, Y, mean)) # trimmed mean unlist(by(X, Y, mean, trim=0.05)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} \keyword{manip} spatstat.geom/man/summary.solist.Rd0000644000176200001440000000155514611065350017125 0ustar liggesusers\name{summary.solist} \alias{summary.solist} \title{Summary of a List of Spatial Objects} \description{ Prints a useful summary of each entry in a list of two-dimensional spatial objects. } \usage{ \method{summary}{solist}(object, \dots) } \arguments{ \item{object}{ An object of class \code{"solist"}. } \item{\dots}{ Ignored. } } \details{ This is a method for the generic function \code{\link{summary}}. An object of the class \code{"solist"} is effectively a list of two-dimensional spatial datasets. See \code{\link{solist}}. This function extracts a useful summary of each of the datasets. } \seealso{ \code{\link{solist}}, \code{\link{summary}}, \code{\link{plot.solist}} } \examples{ x <- solist(cells, japanesepines, redwood) summary(x) } \author{\adrian \rolf and \ege } \keyword{spatial} \keyword{methods} spatstat.geom/man/nnmark.Rd0000644000176200001440000000700314643111575015402 0ustar liggesusers\name{nnmark} \alias{nnmark} \title{ Mark of Nearest Neighbour } \description{ Given a marked point pattern dataset \code{X} this function computes, for each desired location \code{y}, the mark attached to the nearest neighbour of \code{y} in \code{X}. The desired locations \code{y} can be either a pixel grid or the point pattern \code{X} itself. } \usage{ nnmark(X, \dots, k = 1, at=c("pixels", "points")) } \arguments{ \item{X}{ A marked point pattern (object of class \code{"ppp"}). } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution. } \item{k}{ Single integer. The \code{k}th nearest data point will be used. } \item{at}{ String specifying whether to compute the values at a grid of pixel locations (\code{at="pixels"}) or only at the points of \code{X} (\code{at="points"}). } } \details{ Given a marked point pattern dataset \code{X} this function computes, for each desired location \code{y}, the mark attached to the point of \code{X} that is nearest to \code{y}. The desired locations \code{y} can be either a pixel grid or the point pattern \code{X} itself. The argument \code{X} must be a marked point pattern (object of class \code{"ppp"}, see \code{\link{ppp.object}}). The marks are allowed to be a vector or a data frame. \itemize{ \item If \code{at="points"}, then for each point in \code{X}, the algorithm finds the nearest \emph{other} point in \code{X}, and extracts the mark attached to it. The result is a vector or data frame containing the marks of the neighbours of each point. \item If \code{at="pixels"} (the default), then for each pixel in a rectangular grid, the algorithm finds the nearest point in \code{X}, and extracts the mark attached to it. The result is an image or a list of images containing the marks of the neighbours of each pixel. The pixel resolution is controlled by the arguments \code{\dots} passed to \code{\link[spatstat.geom]{as.mask}}. } If the argument \code{k} is given, then the \code{k}-th nearest neighbour will be used. } \value{ \emph{If \code{X} has a single column of marks:} \itemize{ \item If \code{at="pixels"} (the default), the result is a pixel image (object of class \code{"im"}). The value at each pixel is the mark attached to the nearest point of \code{X}. \item If \code{at="points"}, the result is a vector or factor of length equal to the number of points in \code{X}. Entries are the mark values of the nearest neighbours of each point of \code{X}. } \emph{If \code{X} has a data frame of marks:} \itemize{ \item If \code{at="pixels"} (the default), the result is a named list of pixel images (object of class \code{"im"}). There is one image for each column of marks. This list also belongs to the class \code{"solist"}, for which there is a plot method. \item If \code{at="points"}, the result is a data frame with one row for each point of \code{X}, Entries are the mark values of the nearest neighbours of each point of \code{X}. } } \author{\adrian \rolf and \ege } \seealso{ \code{\link[spatstat.explore]{Smooth.ppp}}, \code{\link[spatstat.explore]{marktable}}, \code{\link{nnwhich}} } \examples{ plot(nnmark(ants)) v <- nnmark(ants, at="points") v[1:10] plot(nnmark(finpines)) vf <- nnmark(finpines, at="points") vf[1:5,] } \keyword{spatial} \keyword{methods} \keyword{smooth} spatstat.geom/man/restrict.colourmap.Rd0000644000176200001440000000320114611065350017741 0ustar liggesusers\name{restrict.colourmap} \alias{restrict.colourmap} \title{ Restrict a Colour Map to a Subset of Values } \description{ Given a colour map defined on a range of numerical values or a set of discrete inputs, the command restricts the range of values to a narrower range, or restricts the set of inputs to a subset, and returns the associated colour map. } \usage{ restrict.colourmap(x, ..., range = NULL, breaks = NULL, inputs = NULL) } \arguments{ \item{x}{ Colour map (object of class \code{"colourmap"}). } \item{\dots}{ Ignored. } \item{range}{ New, restricted range of numerical values to which the colour map will apply. A numeric vector of length 2 giving the minimum and maximum values of the input. Incompatible with \code{breaks} and \code{inputs}. } \item{breaks}{ Vector of breakpoints for the new colour map. A numeric vector with increasing entries. Incompatible with \code{range} and \code{inputs}. } \item{inputs}{ Values accepted as inputs for the new colour map. A factor or vector. Incompatible with \code{breaks} and \code{range}. } } \details{ This command produces a new colour map \code{y} which is consistent with the original colour map \code{x}, except that \code{y} is defined on a narrower interval of numeric values, or a smaller set of discrete input values, than \code{x}. } \value{ Colour map (object of class \code{"colourmap"}). } \author{ \adrian. } \seealso{ \code{\link{colourmap}} } \examples{ plot(a <- colourmap(topo.colors(128), range=c(-1,1))) plot(b <- restrict.colourmap(a, range=c(0,1))) } \keyword{spatial} \keyword{color} spatstat.geom/man/summary.im.Rd0000644000176200001440000000360614611065350016214 0ustar liggesusers\name{summary.im} \alias{summary.im} \alias{print.summary.im} \title{Summarizing a Pixel Image} \description{ \code{summary} method for class \code{"im"}. } \usage{ \method{summary}{im}(object, \dots) \method{print}{summary.im}(x, \dots) } \arguments{ \item{object}{A pixel image.} \item{\dots}{Ignored.} \item{x}{Object of class \code{"summary.im"} as returned by \code{summary.im}. } } \details{ This is a method for the generic \code{\link{summary}} for the class \code{"im"}. An object of class \code{"im"} describes a pixel image. See \code{\link{im.object}}) for details of this class. \code{summary.im} extracts information about the pixel image, and \code{print.summary.im} prints this information in a comprehensible format. In normal usage, \code{print.summary.im} is invoked implicitly when the user calls \code{summary.im} without assigning its value to anything. See the examples. The information extracted by \code{summary.im} includes \describe{ \item{range}{The range of the image values.} \item{mean}{The mean of the image values.} \item{integral}{The ``integral'' of the image values, calculated as the sum of the image values multiplied by the area of one pixel.} \item{dim}{The dimensions of the pixel array: \code{dim[1]} is the number of rows in the array, corresponding to the \bold{y} coordinate.} } } \value{ \code{summary.im} returns an object of class \code{"summary.im"}, while \code{print.summary.im} returns \code{NULL}. } \seealso{ \code{\link{mean.im}}, \code{\link{integral.im}}, \code{\link{anyNA.im}} } \examples{ # make an image X <- as.im(function(x,y) {x^2}, unit.square()) # summarize it summary(X) # save the summary s <- summary(X) # print it print(X) s # extract stuff X$dim X$range X$integral } \author{\adrian and \rolf } \keyword{spatial} \keyword{methods} spatstat.geom/man/Frame.Rd0000644000176200001440000000312714611065344015146 0ustar liggesusers\name{Frame} \alias{Frame} \alias{Frame<-} \alias{Frame.default} \alias{Frame<-.default} \alias{Frame<-.owin} \alias{Frame<-.ppp} \alias{Frame<-.im} \title{ Extract or Change the Containing Rectangle of a Spatial Object } \description{ Given a spatial object (such as a point pattern or pixel image) in two dimensions, these functions extract or change the containing rectangle inside which the object is defined. } \usage{ Frame(X) \method{Frame}{default}(X) Frame(X) <- value \method{Frame}{owin}(X) <- value \method{Frame}{ppp}(X) <- value \method{Frame}{im}(X) <- value \method{Frame}{default}(X) <- value } \arguments{ \item{X}{ A spatial object such as a point pattern, line segment pattern or pixel image. } \item{value}{ A rectangular window (object of class \code{"owin"} of type \code{"rectangle"}) to be used as the new containing rectangle for \code{X}. } } \details{ The functions \code{Frame} and \code{Frame<-} are generic. \code{Frame(X)} extracts the rectangle inside which \code{X} is defined. \code{Frame(X) <- R} changes the rectangle inside which \code{X} is defined to the new rectangle \code{R}. } \value{ The result of \code{Frame} is a rectangular window (object of class \code{"owin"} of type \code{"rectangle"}). The result of \code{Frame<-} is the updated object \code{X}, of the same class as \code{X}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{Window}} } \examples{ Frame(cells) X <- demopat Frame(X) Frame(X) <- owin(c(0, 11000), c(400, 8000)) } \keyword{spatial} \keyword{manip} spatstat.geom/man/as.data.frame.ppp.Rd0000644000176200001440000000176314611065345017323 0ustar liggesusers\name{as.data.frame.ppp} \alias{as.data.frame.ppp} \title{Coerce Point Pattern to a Data Frame} \description{ Extracts the coordinates of the points in a point pattern, and their marks if any, and returns them in a data frame. } \usage{ \method{as.data.frame}{ppp}(x, row.names = NULL, ...) } \arguments{ \item{x}{Point pattern (object of class \code{"ppp"}).} \item{row.names}{Optional character vector of row names.} \item{\dots}{Ignored.} } \details{ This is a method for the generic function \code{\link{as.data.frame}} for the class \code{"ppp"} of point patterns. It extracts the coordinates of the points in the point pattern, and returns them as columns named \code{x} and \code{y} in a data frame. If the points were marked, the marks are returned as a column named \code{marks} with the same type as in the point pattern dataset. } \value{ A data frame. } \examples{ df <- as.data.frame(amacrine) df[1:5,] } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/delaunay.Rd0000644000176200001440000000254714611065345015724 0ustar liggesusers\name{delaunay} \alias{delaunay} \title{Delaunay Triangulation of Point Pattern} \description{ Computes the Delaunay triangulation of a spatial point pattern. } \usage{ delaunay(X) } \arguments{ \item{X}{Spatial point pattern (object of class \code{"ppp"}).} } \details{ The Delaunay triangulation of a spatial point pattern \code{X} is defined as follows. First the Dirichlet/Voronoi tessellation based on \code{X} is computed; see \code{\link{dirichlet}}. This tessellation is extended to cover the entire two-dimensional plane. Then two points of \code{X} are defined to be Delaunay neighbours if their Dirichlet/Voronoi tiles share a common boundary. Every pair of Delaunay neighbours is joined by a straight line to make the Delaunay triangulation. The result is a tessellation, consisting of disjoint triangles. The union of these triangles is the convex hull of \code{X}. } \value{ A tessellation (object of class \code{"tess"}). The window of the tessellation is the convex hull of \code{X}, not the original window of \code{X}. } \seealso{ \code{\link{tess}}, \code{\link{dirichlet}}, \code{\link{convexhull.xy}}, \code{\link{ppp}}, \code{\link{delaunayDistance}}, \code{delaunayNetwork}. } \examples{ X <- runifrect(42) plot(delaunay(X)) plot(X, add=TRUE) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/framedist.pixels.Rd0000644000176200001440000000413514643111575017400 0ustar liggesusers\name{framedist.pixels} \alias{framedist.pixels} \alias{framedist.pixels} \title{Distance to Bounding Frame} \description{ Computes the distances from each pixel to the bounding rectangle. } \usage{ framedist.pixels(w, \dots, style=c("image", "matrix", "coords")) } \arguments{ \item{w}{A window (object of class \code{"owin"}).} \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution.} \item{style}{ Character string (partially matched) determining the format of the output: either \code{"matrix"}, \code{"coords"} or \code{"image"}. } } \value{ If \code{style="image"}, a pixel image (object of class \code{"im"}) containing the distances from each pixel in the image raster to the boundary of the window. If \code{style="matrix"}, a matrix giving the distances from each pixel in the image raster to the boundary of the window. Rows of this matrix correspond to the \eqn{y} coordinate and columns to the \eqn{x} coordinate. If \code{style="coords"}, a list with three components \code{x,y,z}, where \code{x,y} are vectors of length \eqn{m,n} giving the \eqn{x} and \eqn{y} coordinates respectively, and \code{z} is an \eqn{m \times n}{m x n} matrix such that \code{z[i,j]} is the distance from \code{(x[i],y[j])} to the boundary of the window. Rows of this matrix correspond to the \eqn{x} coordinate and columns to the \eqn{y} coordinate. This result can be plotted with \code{persp}, \code{image} or \code{contour}. } \details{ This function computes, for each pixel \eqn{u} in the rectangular frame \code{Frame(w)}, the shortest distance to the boundary of \eqn{Frame(w)}. The grid of pixels is determined by the arguments \code{"\dots"} passed to \code{\link[spatstat.geom]{as.mask}}. The distance from each pixel to the boundary is calculated exactly, using analytic geometry. } \seealso{ \code{\link{bdist.pixels}}. } \examples{ opa <- par(mfrow=c(1,2)) plot(framedist.pixels(letterR)) plot(bdist.pixels(letterR)) par(opa) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/affine.owin.Rd0000644000176200001440000000335214643111575016322 0ustar liggesusers\name{affine.owin} \alias{affine.owin} \title{Apply Affine Transformation To Window} \description{ Applies any affine transformation of the plane (linear transformation plus vector shift) to a window. } \usage{ \method{affine}{owin}(X, mat=diag(c(1,1)), vec=c(0,0), \dots, rescue=TRUE) } \arguments{ \item{X}{Window (object of class \code{"owin"}).} \item{mat}{Matrix representing a linear transformation.} \item{vec}{Vector of length 2 representing a translation.} \item{rescue}{ Logical. If \code{TRUE}, the transformed window will be processed by \code{\link{rescue.rectangle}}. } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution of the transformed window, if \code{X} is a binary pixel mask. } } \value{ Another window (of class \code{"owin"}) representing the result of applying the affine transformation. } \details{ The window is subjected first to the linear transformation represented by \code{mat} (multiplying on the left by \code{mat}), and then the result is translated by the vector \code{vec}. The argument \code{mat} must be a nonsingular \eqn{2 \times 2}{2 * 2} matrix. This is a method for the generic function \code{\link{affine}}. } \seealso{ \code{\link{affine}}, \code{\link{affine.ppp}}, \code{\link{affine.psp}}, \code{\link{affine.im}}, \code{\link{rotate}}, \code{\link{shift}} } \examples{ # shear transformation shear <- matrix(c(1,0,0.6,1),ncol=2) X <- affine(owin(), shear) if(interactive()) plot(X) affine(letterR, shear, c(0, 0.5)) affine(as.mask(letterR), shear, c(0, 0.5)) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} \concept{Geometrical transformations} spatstat.geom/man/clickdist.Rd0000644000176200001440000000164714611065345016073 0ustar liggesusers\name{clickdist} \alias{clickdist} \title{Interactively Measure Distance} \description{ Measures the distance between two points which the user has clicked on. } \usage{ clickdist() } \value{ A single nonnegative number. } \details{ This function allows the user to measure the distance between two spatial locations, interactively, by clicking on the screen display. When \code{clickdist()} is called, the user is expected to click two points in the current graphics device. The distance between these points will be returned. This function uses the \R{} command \code{\link[graphics]{locator}} to input the mouse clicks. It only works on screen devices such as \sQuote{X11}, \sQuote{windows} and \sQuote{quartz}. } \seealso{ \code{\link[graphics]{locator}}, \code{\link{clickppp}}, \code{\link{clickpoly}}, \code{\link{clickbox}} } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{iplot} spatstat.geom/man/discs.Rd0000644000176200001440000000643214643111575015226 0ustar liggesusers\name{discs} \alias{discs} \title{ Union of Discs } \description{ Make a spatial region composed of discs with given centres and radii. } \usage{ discs(centres, radii = marks(centres)/2, \dots, separate = FALSE, mask = FALSE, trim = TRUE, delta = NULL, npoly=NULL) } \arguments{ \item{centres}{ Point pattern giving the locations of centres for the discs. } \item{radii}{ Vector of radii for each disc, or a single number giving a common radius. (Notice that the default assumes that the marks of \code{X} are \emph{diameters}.) } \item{\dots}{ Optional arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution, if \code{mask=TRUE}. } \item{separate}{ Logical. If \code{TRUE}, the result is a list containing each disc as a separate entry. If \code{FALSE} (the default), the result is a window obtained by forming the union of the discs. } \item{mask}{ Logical. If \code{TRUE}, the result is a binary mask window. If \code{FALSE}, the result is a polygonal window. Applies only when \code{separate=FALSE}. } \item{trim}{ Logical value indicating whether to restrict the result to the original window of the \code{centres}. Applies only when \code{separate=FALSE}. } \item{delta}{ Argument passed to \code{\link{disc}} to determine the tolerance for the polygonal approximation of each disc. Applies only when \code{mask=FALSE}. Incompatible with \code{npoly}. } \item{npoly}{ Argument passed to \code{\link{disc}} to determine the number of edges in the polygonal approximation of each disc. Applies only when \code{mask=FALSE}. Incompatible with \code{delta}. } } \details{ This command is typically applied to a marked point pattern dataset \code{X} in which the marks represent the sizes of objects. The result is a spatial region representing the space occupied by the objects. If the marks of \code{X} represent the diameters of circular objects, then the result of \code{discs(X)} is a spatial region constructed by taking discs, of the specified diameters, centred at the points of \code{X}, and forming the union of these discs. If the marks of \code{X} represent the areas of objects, one could take \code{discs(X, sqrt(marks(X)/pi))} to produce discs of equivalent area. A fast algorithm is used to compute the result as a binary mask, when \code{mask=TRUE}. This option is recommended unless polygons are really necessary. If \code{mask=FALSE}, the discs will be constructed as polygons by the function \code{\link{disc}}. To avoid computational problems, by default, the discs will all be constructed using the same physical tolerance value \code{delta} passed to \code{\link{disc}}. The default is such that the smallest disc will be approximated by a 16-sided polygon. (The argument \code{npoly} should not normally be used, to avoid computational problems arising with small radii.) } \value{ If \code{separate=FALSE}, a window (object of class \code{"owin"}). If \code{separate=TRUE}, a list of windows. } \author{ \spatstatAuthors. } \seealso{ \code{\link{disc}}, \code{\link{union.owin}} } \examples{ plot(discs(anemones, mask=TRUE, eps=0.5)) } \keyword{spatial} \keyword{datagen} spatstat.geom/man/rescale.ppp.Rd0000644000176200001440000000371514611065350016330 0ustar liggesusers\name{rescale.ppp} \alias{rescale.ppp} \title{Convert Point Pattern to Another Unit of Length} \description{ Converts a point pattern dataset to another unit of length. } \usage{ \method{rescale}{ppp}(X, s, unitname) } \arguments{ \item{X}{Point pattern (object of class \code{"ppp"}).} \item{s}{Conversion factor: the new units are \code{s} times the old units.} \item{unitname}{ Optional. New name for the unit of length. See \code{\link{unitname}}. } } \value{ Another point pattern (of class \code{"ppp"}), representing the same data, but expressed in the new units. } \details{ This is a method for the generic function \code{\link{rescale}}. The spatial coordinates in the point pattern \code{X} (and its window) will be re-expressed in terms of a new unit of length that is \code{s} times the current unit of length given in \code{X}. (Thus, the coordinate values are \emph{divided} by \code{s}, while the unit value is multiplied by \code{s}). The result is a point pattern representing the \emph{same} data but re-expressed in a different unit. Mark values are unchanged. If \code{s} is missing, then the coordinates will be re-expressed in \sQuote{native} units; for example if the current unit is equal to 0.1 metres, then the coordinates will be re-expressed in metres. } \section{Note}{ The result of this operation is equivalent to the original point pattern. If you want to actually change the coordinates by a linear transformation, producing a point pattern that is not equivalent to the original one, use \code{\link{affine}}. } \seealso{ \code{\link{unitname}}, \code{\link{rescale}}, \code{\link{rescale.owin}}, \code{\link{affine}}, \code{\link{rotate}}, \code{\link{shift}} } \examples{ # Bramble Canes data: 1 unit = 9 metres # convert to metres bram <- rescale(bramblecanes, 1/9) # or equivalently bram <- rescale(bramblecanes) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/pppmatching.object.Rd0000644000176200001440000000655514611065350017700 0ustar liggesusers\name{pppmatching.object} \alias{pppmatching.object} %DoNotExport \title{Class of Point Matchings} \description{ A class \code{"pppmatching"} to represent a matching of two planar point patterns. Optionally includes information about the construction of the matching and its associated distance between the point patterns. } \details{ This class represents a (possibly weighted and incomplete) matching between two planar point patterns (objects of class \code{"ppp"}). A matching can be thought of as a bipartite weighted graph where the vertices are given by the two point patterns and edges of positive weights are drawn each time a point of the first point pattern is "matched" with a point of the second point pattern. If \code{m} is an object of type \code{pppmatching}, it contains the following elements \tabular{ll}{ \code{pp1, pp2} \tab the two point patterns to be matched (vertices) \cr \code{matrix} \tab a matrix specifying which points are matched \cr \tab and with what weights (edges) \cr \code{type} \tab (optional) a character string for the type of \cr \tab the matching (one of \code{"spa"}, \code{"ace"} or \code{"mat"}) \cr \code{cutoff} \tab (optional) cutoff value for interpoint distances \cr \code{q} \tab (optional) the order for taking averages of \cr \tab interpoint distances \cr \code{distance} \tab (optional) the distance associated with the matching } The element \code{matrix} is a "generalized adjacency matrix". The numbers of rows and columns match the cardinalities of the first and second point patterns, respectively. The \code{[i,j]}-th entry is positive if the \code{i}-th point of \code{X} and the \code{j}-th point of \code{Y} are matched (zero otherwise) and its value then gives the corresponding weight of the match. For an unweighted matching all the weights are set to \eqn{1}. The optional elements are for saving details about matchings in the context of optimal point matching techniques. \code{type} can be one of \code{"spa"} (for "subpattern assignment"), \code{"ace"} (for "assignment only if cardinalities differ") or \code{"mat"} (for "mass transfer"). \code{cutoff} is a positive numerical value that specifies the maximal interpoint distance and \code{q} is a value in \eqn{[1,\infty]}{[1,Inf]} that gives the order of the average applied to the interpoint distances. See the help files for \code{\link{pppdist}} and \code{\link{matchingdist}} for detailed information about these elements. Objects of class \code{"pppmatching"} may be created by the function \code{\link{pppmatching}}, and are most commonly obtained as output of the function \code{\link{pppdist}}. There are methods \code{plot}, \code{print} and \code{summary} for this class. } \author{ \dominic. } \seealso{ \code{\link{matchingdist}}, \code{\link{pppmatching}}, \code{\link{plot.pppmatching}} } \examples{ # a random complete unweighted matching X <- runifrect(10) Y <- runifrect(10) am <- r2dtable(1, rep(1,10), rep(1,10))[[1]] # generates a random permutation matrix m <- pppmatching(X, Y, am) summary(m) m$matrix if(interactive()) { plot(m) } # an optimal complete unweighted matching m2 <- pppdist(X,Y) summary(m2) m2$matrix if(interactive()) { plot(m2) } } \keyword{spatial} \keyword{attribute} spatstat.geom/man/spatstat.geom-internal.Rd0000644000176200001440000004731314765743246020542 0ustar liggesusers\name{spatstat.geom-internal} \title{Internal spatstat.geom functions} \alias{spatstat.geom-internal} %DoNotExport \alias{[.diagramobj} \alias{[.pp3} \alias{[.splitppx} \alias{[<-.splitppx} \alias{acedist.show} \alias{acedist.noshow} \alias{affine.diagramobj} \alias{affinexy} \alias{affinexypolygon} \alias{allElementsIdentical} \alias{anycrossing.psp} \alias{applytolayers} \alias{applyPolyclipArgs} \alias{areaGain.diri} \alias{areaGain.grid} \alias{areaLoss.diri} \alias{areaLoss.grid} \alias{areaLoss.poly} \alias{AsMaskInternal} \alias{AsymmDistance.psp} \alias{as.character.unitname} \alias{as.data.frame.ppplist} \alias{as.double.im} \alias{as.imlist} \alias{as.linimlist} \alias{as.list.hyperframe} \alias{as.listof} \alias{as.ppplist} \alias{as.tess.tessfun} \alias{as.unitname} \alias{avenndist} \alias{bbEngine} \alias{bdry.mask} \alias{boundingbox.list} \alias{bounding.box3} \alias{break.holes} \alias{cartesian} \alias{cellmiddles} \alias{checkbigmatrix} \alias{checkfields} \alias{check.arc} \alias{check.finespacing} \alias{circunion} \alias{clip.psp} \alias{cliprect.psp} \alias{clippoly.psp} \alias{closethresh} \alias{cocoEngine} \alias{coerce.marks.numeric} \alias{crosspairquad} \alias{cobble.xy} \alias{codetime} \alias{col.args.to.grey} \alias{commonPolyclipArgs} \alias{conform.imagelist} \alias{countingweights} \alias{default.n.tiling} \alias{default.ntile} \alias{dimnames.hyperframe} \alias{dimnames<-.hyperframe} \alias{dflt.redraw} \alias{diagramobj} \alias{dim.hyperframe} \alias{dim.im} \alias{dim.owin} \alias{dist2dpath} \alias{do.as.im} \alias{do.call.plotfun} \alias{drawSignedPoly} \alias{emptywindow} \alias{equalpairs.quad} \alias{equals.quad} \alias{equalsfun.quad} \alias{erodemask} \alias{even.breaks.owin} \alias{exactdt} \alias{exactPdt} \alias{existsSpatstatVariable} \alias{expandSpecialLists} \alias{fakemaintitle} \alias{fft2D} \alias{fftwAvailable} \alias{fillNA} \alias{flipxy.diagramobj} \alias{flipxypolygon} \alias{format.numberwithunit} \alias{framebottomleft} \alias{gammabreaks} \alias{genericNNdistBy} \alias{getfields} \alias{getlastshift} \alias{getSpatstatVariable} \alias{gridindex} \alias{grid1index} \alias{grow.mask} \alias{handle.r.b.args} \alias{head.hyperframe} \alias{hsvNA} \alias{idorempty} \alias{imageOp} \alias{imagelistOp} \alias{inpoint} \alias{inside.arc} \alias{interpretAsOrigin} \alias{intX.owin} \alias{intX.xypolygon} \alias{intY.owin} \alias{intY.xypolygon} \alias{invokeColourmapRule} \alias{is.col.argname} \alias{is.data} \alias{is.fv} \alias{is.hyperframe} \alias{is.imlist} \alias{is.infline} \alias{is.marked.default} \alias{is.marked.psp} \alias{is.marked.quad} \alias{is.multitype.default} \alias{is.multitype.quad} \alias{is.ppplist} \alias{is.pp3} \alias{is.ppx} \alias{is.psp} \alias{is.quad} \alias{is.sob} \alias{is.solist} \alias{is.tess} \alias{is.vanilla} \alias{levels.im} \alias{levels<-.im} \alias{levelsAsFactor} \alias{listof} \alias{logi.dummy} \alias{markvaluetype} \alias{packupNNdata} \alias{parbreak} \alias{perspVisible} \alias{plan.legend.layout} \alias{pointweights} \alias{polytileareaEngine} \alias{putSpatstatVariable} \alias{lookup.im} \alias{majorminorversion} \alias{makeunitname} \alias{markappend} \alias{markcbind} \alias{markformat} \alias{markformat.ppp} \alias{markformat.ppx} \alias{markformat.psp} \alias{markformat.default} \alias{mark.scale.default} \alias{markspace.integral} \alias{marks.default} \alias{marks.quad} \alias{\%mapp\%} %DoNotExport %NAMESPACE export("%mapp%") \alias{markappendop} \alias{marksubset} \alias{markreplicateop} \alias{\%mrep\%} %DoNotExport %NAMESPACE export("%mrep%") \alias{marksubsetop} \alias{\%msub\%} %DoNotExport %NAMESPACE export("%msub%") \alias{mask2df} \alias{maxflow} \alias{meanX.owin} \alias{meanY.owin} \alias{MinimalTess} \alias{multiplicityNumeric} \alias{multiply.only.finite.entries} \alias{na.handle.im} \alias{names.hyperframe} \alias{names<-.hyperframe} \alias{nearest.pixel} \alias{nearest.valid.pixel} \alias{n.quad} \alias{numberwithunit} \alias{numeric.columns} \alias{onecolumn} \alias{owinInternalRect} \alias{owinInternalMask} \alias{owinInternalPoly} \alias{owinpolycheck} \alias{owinpoly2mask} \alias{owin2polypath} \alias{param.quad} \alias{PDtoNN} \alias{pickoption} \alias{plotEachLayer} \alias{plot3Dpoints} \alias{plotPolygonBdry} \alias{plotWidthMap} \alias{plot.barplotdata} \alias{plot.indicfun} \alias{plot.tessfun} \alias{pointgrid} \alias{ppllengine} \alias{pppdist.mat} \alias{pppdist.prohorov} \alias{ppsubset} \alias{prepareTitle} \alias{print.anylist} \alias{print.colourmap} \alias{print.distfun} \alias{print.funxy} \alias{print.hyperframe} \alias{print.indicfun} \alias{print.layered} \alias{print.lut} \alias{print.metric} \alias{print.metricfun} \alias{print.nnfun} \alias{print.numberwithunit} \alias{print.onearrow} \alias{print.pppmatching} \alias{print.simplepanel} \alias{print.solist} \alias{print.splitppp} \alias{print.splitppx} \alias{print.summary.distfun} \alias{print.summary.funxy} \alias{print.summary.hyperframe} \alias{print.summary.listof} \alias{print.summary.logiquad} \alias{print.summary.lut} \alias{print.summary.owin} \alias{print.summary.ppp} \alias{print.summary.psp} \alias{print.summary.solist} \alias{print.summary.splitppp} \alias{print.summary.splitppx} \alias{print.summary.symbolmap} \alias{print.summary.unitname} \alias{print.symbolmap} \alias{print.tessfun} \alias{print.textstring} \alias{print.texturemap} \alias{print.tess} \alias{print.timed} \alias{print.yardstick} \alias{project3Dhom} \alias{putlastshift} \alias{qtPrepareCoordinate} \alias{quad} \alias{quadscheme.replicated} \alias{quadscheme.spatial} \alias{rasterfilter} \alias{rastersample} \alias{rasterx.mask} \alias{rastery.mask} \alias{rasterxy.mask} \alias{rasterx.im} \alias{rastery.im} \alias{rasterxy.im} \alias{rebound} \alias{rebound.im} \alias{rebound.ppp} \alias{rebound.psp} \alias{rebound.owin} \alias{recognise.spatstat.type} \alias{rectquadrat.breaks} \alias{rectquadrat.countEngine} \alias{reflect.diagramobj} \alias{remove.identical.pairs} \alias{repair.image.xycoords} \alias{repair.old.factor.image} \alias{resolve.stringsAsFactors} \alias{restrict.mask} \alias{reversePolyclipArgs} \alias{rgbNA} \alias{rotate.diagramobj} \alias{rotxy} \alias{rotxypolygon} \alias{row.names.hyperframe} \alias{row.names<-.hyperframe} \alias{ruletextline} \alias{safedeldir} \alias{safeDevCapabilities} \alias{safelookup} \alias{scalardilate.breakpts} \alias{scalardilate.diagramobj} \alias{shift.diagramobj} \alias{shift.quadratcount} \alias{shiftxy} \alias{shiftxypolygon} \alias{simulationresult} \alias{smudge} \alias{sort.im} \alias{spatstatDiagnostic} \alias{spatstat.deldir.setopt} \alias{spatstat.xy.coords} \alias{store.versionstring.spatstat} \alias{str.hyperframe} \alias{summary.hyperframe} \alias{summary.logiquad} \alias{summary.lut} \alias{summary.metric} \alias{summary.pppmatching} \alias{summary.ppx} \alias{summary.splitppx} \alias{summary.symbolmap} \alias{superimposeMarks} \alias{symbolmapdomain} \alias{symbolmapparnames} \alias{symbolmaptype} \alias{symbol.sizes.default} \alias{tail.hyperframe} \alias{tessfunvalues} \alias{thickSegments} \alias{tilecentroids} \alias{trianglediameters} \alias{trim.mask} \alias{tweak.closepairs} \alias{\%unit\%} %DoNotExport %NAMESPACE export("%unit%") \alias{unitname.default} \alias{unitname<-.default} \alias{unstackFilter} \alias{update.im} \alias{validradius} \alias{validate.mask} \alias{validate.quad} \alias{versioncurrency.spatstat} \alias{versionstring.spatstat} \alias{verifyclass} \alias{veryunique} \alias{warn.once} \alias{warn.no.metric.support} \alias{warn.unsupported.args} \alias{waxlyrical} \alias{wrangle2image} \alias{w.quad} \alias{x.quad} \alias{y.quad} \alias{xy.grid} \alias{xtfrm.im} \alias{XDtoNN} \alias{xypolygon2psp} \alias{xypolyselfint} \alias{ZeroValue} \alias{ZeroValue.im} %%%%%%% \description{ Internal spatstat.geom functions. } \usage{ \method{[}{diagramobj}(x, \dots) \method{[}{pp3}(x, i, drop, \dots) \method{[}{splitppx}(x, \dots) \method{[}{splitppx}(x, \dots) <- value acedist.show(X, Y, n, d, timelag) acedist.noshow(X, Y, n, d) \method{affine}{diagramobj}(X, \dots) affinexy(X, mat, vec, invert) affinexypolygon(p, mat, vec, detmat) allElementsIdentical(x, entry) anycrossing.psp(A,B) applytolayers(L, FUN, \dots) applyPolyclipArgs(x, p) areaGain.diri(u, X, r, \dots, W, verbose) areaGain.grid(u, X, r, \dots, W, ngrid) areaLoss.diri(X, r, \dots, W, subset) areaLoss.grid(X, r, \dots, W, subset, method = c("count", "distmap"), ngrid = spatstat.options("ngrid.disc"), exact = FALSE) areaLoss.poly(X, r, \dots, W, subset, splitem) AsMaskInternal(w, \dots, eps, dimyx, xy, rule.eps) AsymmDistance.psp(X, Y, metric, method) \method{as.character}{unitname}(x, \dots) \method{as.data.frame}{ppplist}(x, row.names, \dots) \method{as.double}{im}(x, \dots) as.imlist(x, check) as.linimlist(x, check) \method{as.list}{hyperframe}(x, \dots) as.listof(x) as.ppplist(x, check) \method{as.tess}{tessfun}(X) as.unitname(s) avenndist(X) bbEngine(\dots) bdry.mask(W) \method{boundingbox}{list}(\dots) bounding.box3(\dots) break.holes(x, splitby, depth, maxdepth) cartesian(pp, markset, fac = TRUE) cellmiddles(W, nx, ny, npix, distances) checkbigmatrix(n, m, fatal, silent) checkfields(X,L) check.arc(arc, fatal) check.finespacing(r, eps, win, rmaxdefault, context, action, rname) circunion(arcs) clip.psp(x, window, check, fragments) cliprect.psp(x, window, fragments) clippoly.psp(s, window, fragments) closethresh(X,R,S,twice,\dots) cocoEngine(nv, ie, je, algoname) coerce.marks.numeric(X, warn) crosspairquad(Q,rmax,what) cobble.xy(x, y, f, fatal, \dots) codetime(x, hms, what) col.args.to.grey(x, \dots) commonPolyclipArgs(\dots, p) conform.imagelist(X, Zlist) countingweights(id, areas, check = TRUE) default.n.tiling(X, nd, ntile, npix, eps, random, quasi, verbose) default.ntile(X) \method{dimnames}{hyperframe}(x) \method{dimnames}{hyperframe}(x) <- value dflt.redraw(button, name, env) diagramobj(X, \dots) \method{dim}{hyperframe}(x) \method{dim}{im}(x) \method{dim}{owin}(x) dist2dpath(dist, method="C") do.as.im(x, action, \dots, W, eps, dimyx, xy, rule.eps, na.replace) do.call.plotfun(fun, arglist, \dots, envir) drawSignedPoly(x,y,pars,sgn) emptywindow(w) equalpairs.quad(Q) equals.quad(Q) equalsfun.quad(Q) erodemask(w,r,strict) even.breaks.owin(w) exactdt(X, \dots) exactPdt(w) existsSpatstatVariable(name) expandSpecialLists(x, special) fakemaintitle(bb, main, \dots) fft2D(z, inverse, west) fftwAvailable() fillNA(x, value) \method{flipxy}{diagramobj}(X) flipxypolygon(p) \method{format}{numberwithunit}(x, \dots, collapse, modifier) framebottomleft(w) gammabreaks(ra, n, gamma) genericNNdistBy(X, by, k) getfields(X, L, fatal = TRUE) getlastshift(X) getSpatstatVariable(name, default) gridindex(x, y, xrange, yrange, nx, ny) grid1index(x, xrange, nx) grow.mask(M, xmargin=0, ymargin=xmargin) handle.r.b.args(r = NULL, breaks = NULL, window, pixeps = NULL, rmaxdefault) \method{head}{hyperframe}(x,n,\dots) hsvNA(h, s, v, alpha) idorempty(w, r, caller) imageOp(e1, e2, op) imagelistOp(e1, e2, op) inpoint(W) inside.arc(theta, arc) interpretAsOrigin(x, W) intX.owin(w) intX.xypolygon(polly) intY.owin(w) intY.xypolygon(polly) invokeColourmapRule(colfun, x, \dots, zlim, colargs) is.col.argname(x) is.data(Q) is.fv(x) is.hyperframe(x) is.imlist(x) is.infline(x) \method{is.marked}{default}(\dots) \method{is.marked}{psp}(X, \dots) \method{is.marked}{quad}(X, na.action="warn", \dots) \method{is.multitype}{default}(X, \dots) \method{is.multitype}{quad}(X, na.action="warn", \dots) is.ppplist(x) is.pp3(x) is.ppx(x) is.psp(x) is.quad(x) is.solist(x) is.sob(x) is.tess(x) is.vanilla(u) \method{levels}{im}(x) \method{levels}{im}(x) <- value levelsAsFactor(x) listof(\dots) logi.dummy(X, dummytype, nd, mark.repeat, \dots) markvaluetype(x) packupNNdata(NND, NNW, what, k) parbreak(terse) perspVisible(x, y, z, M) plan.legend.layout(B, \dots, side, sep, leg.size, sep.frac, size.frac, started, map) pointweights(X, \dots, weights, parent, dfok) polytileareaEngine(P, xrange, yrange, nx, ny, DivideByPixelArea) putSpatstatVariable(name, value) lookup.im(Z, x, y, naok, strict) majorminorversion(v) makeunitname(sing, plur, mul) markappend(\dots) markcbind(\dots) markformat(x) \method{markformat}{ppp}(x) \method{markformat}{ppx}(x) \method{markformat}{psp}(x) \method{markformat}{default}(x) mark.scale.default(marx, w, \dots, markrange, markscale, maxsize, meansize, minsize, zerosize, characters) markspace.integral(X) \method{marks}{default}(x, \dots) \method{marks}{quad}(x, dfok=FALSE, \dots) markappendop(x, y) x \%mapp\% y marksubset(x, index, format) marksubsetop(x, i) x \%msub\% i markreplicateop(x, n) x \%mrep\% n mask2df(w) maxflow(costm) meanX.owin(w) meanY.owin(w) MinimalTess(W, \dots) multiplicityNumeric(x) multiply.only.finite.entries(x, a) na.handle.im(X, na.replace) \method{names}{hyperframe}(x) \method{names}{hyperframe}(x) <- value nearest.pixel(x, y, Z) nearest.valid.pixel(x, y, Z, method, nsearch) n.quad(Q) numberwithunit(x, u) numeric.columns(M, logical, others) onecolumn(m) owinInternalRect(xrange, yrange, \dots, unitname, check) owinInternalMask(xrange, yrange, \dots, mask, unitname, xy, check) owinInternalPoly(xrange, yrange, \dots, poly, unitname, check, calculate, strict, fix) owinpolycheck(W, verbose=TRUE) owinpoly2mask(w, rasta, check=TRUE) owin2polypath(w) param.quad(Q) PDtoNN(d, what, k, \dots) pickoption(what="option", key, keymap, \dots, exact=FALSE, list.on.err=TRUE, die=TRUE, multi=FALSE, allow.all=TRUE) plotEachLayer(x, \dots, main, plotargs, add, show.all, do.plot) plot3Dpoints(xyz, eye, org, \dots, type, xlim, ylim, zlim, add, box, main, cex, box.back, box.front) plotPolygonBdry(x, \dots) plotWidthMap(bb.leg, zlim, phys.scale, leg.scale, leg.side, leg.args, grafpar) \method{plot}{barplotdata}(x, \dots) \method{plot}{indicfun}(x, W, \dots, main) \method{plot}{tessfun}(x, \dots) pointgrid(W, ngrid) ppllengine(X, Y, action="project", check=FALSE) pppdist.mat(X, Y, cutoff = 1, q = 1, matching = TRUE, precision = 9, approximation = 10) pppdist.prohorov(X, Y, n, dfix, type, cutoff, matching, ccode, auction, precision, approximation) ppsubset(X, I, Iname, fatal) prepareTitle(main) \method{print}{anylist}(x, \dots) \method{print}{colourmap}(x, \dots) \method{print}{distfun}(x, \dots) \method{print}{funxy}(x, \dots) \method{print}{hyperframe}(x, \dots) \method{print}{indicfun}(x, \dots) \method{print}{layered}(x, \dots) \method{print}{lut}(x, \dots) \method{print}{metric}(x, \dots) \method{print}{metricfun}(x, \dots) \method{print}{nnfun}(x, \dots) \method{print}{numberwithunit}(x, \dots) \method{print}{onearrow}(x, \dots) \method{print}{pppmatching}(x, \dots) \method{print}{simplepanel}(x, \dots) \method{print}{solist}(x, \dots) \method{print}{splitppp}(x, \dots) \method{print}{splitppx}(x, \dots) \method{print}{summary.distfun}(x, \dots) \method{print}{summary.funxy}(x, \dots) \method{print}{summary.hyperframe}(x, \dots) \method{print}{summary.listof}(x, \dots) \method{print}{summary.logiquad}(x, \dots, dp=3) \method{print}{summary.lut}(x, \dots) \method{print}{summary.owin}(x, \dots) \method{print}{summary.ppp}(x, \dots, dp) \method{print}{summary.psp}(x, \dots) \method{print}{summary.splitppp}(x, \dots) \method{print}{summary.solist}(x, \dots) \method{print}{summary.splitppx}(x, \dots) \method{print}{summary.symbolmap}(x, \dots) \method{print}{summary.unitname}(x, \dots) \method{print}{symbolmap}(x, \dots) \method{print}{tessfun}(x, \dots) \method{print}{textstring}(x, \dots) \method{print}{texturemap}(x, \dots) \method{print}{tess}(x, \dots, brief=FALSE) \method{print}{timed}(x, \dots) \method{print}{yardstick}(x, \dots) project3Dhom(xyz, eye, org, vert) putlastshift(X, vec) qtPrepareCoordinate(covname, W, origin) quad(data, dummy, w, param) quadscheme.replicated(data, dummy, method, \dots) quadscheme.spatial(data, dummy, method, \dots) rasterfilter(X, f) rastersample(X, Y) rasterx.mask(w, drop) rastery.mask(w, drop) rasterxy.mask(w, drop) rasterx.im(x) rastery.im(x) rasterxy.im(x, drop) rebound(x, rect) \method{rebound}{im}(x, rect) \method{rebound}{ppp}(x, rect) \method{rebound}{psp}(x, rect) \method{rebound}{owin}(x, rect) recognise.spatstat.type(x) rectquadrat.breaks(xr, yr, nx = 5, ny = nx, xbreaks = NULL, ybreaks = NULL) rectquadrat.countEngine(x, y, xbreaks, ybreaks, weights) \method{reflect}{diagramobj}(X) remove.identical.pairs(cl, imap, jmap) repair.image.xycoords(x) repair.old.factor.image(x) resolve.stringsAsFactors(stringsAsFactors) restrict.mask(M, W) reversePolyclipArgs(x, p) rgbNA(red, green, blue, alpha, maxColorValue) \method{rotate}{diagramobj}(X, \dots) rotxy(X, angle = pi/2) rotxypolygon(p, angle = pi/2) \method{row.names}{hyperframe}(x) \method{row.names}{hyperframe}(x) <- value ruletextline(ch, n, terse) safedeldir(X) safeDevCapabilities() safelookup(Z, x, factor, warn) \method{scalardilate}{breakpts}(X, f, \dots) \method{scalardilate}{diagramobj}(X, f, \dots) \method{shift}{diagramobj}(X, \dots) \method{shift}{quadratcount}(X, \dots) shiftxy(X, vec = c(0, 0)) shiftxypolygon(p, vec = c(0, 0)) simulationresult(resultlist, nsim, drop, NameBase) smudge(X) \method{sort}{im}(x, \dots) spatstatDiagnostic(msg) spatstat.deldir.setopt(use.trigrafS, use.trigraf, debug.delaunay) spatstat.xy.coords(x, y) store.versionstring.spatstat() \method{str}{hyperframe}(object, \dots) \method{summary}{hyperframe}(object, \dots, brief=FALSE) \method{summary}{logiquad}(object, \dots, checkdup=FALSE) \method{summary}{lut}(object, \dots) \method{summary}{metric}(object, \dots) \method{summary}{pppmatching}(object, \dots) \method{summary}{ppx}(object, \dots) \method{summary}{splitppx}(object, \dots) \method{summary}{symbolmap}(object, \dots) superimposeMarks(arglist, nobj) symbolmapdomain(x) symbolmapparnames(x) symbolmaptype(x) symbol.sizes.default(markvalues, \dots) \method{tail}{hyperframe}(x,n,\dots) tessfunvalues(f) thickSegments(x, widths, \dots, add, main, do.plot, show.all, show.window, scale, adjust, negative.args, legend, leg.side, leg.sep, leg.wid, leg.args, leg.scale, zlim, box) tilecentroids(W, nx, ny) trianglediameters(iedge, jedge, edgelength, \dots, nvert, dmax, check) trim.mask(M, R, tolerant) tweak.closepairs(cl, rmax, i, deltax, deltay, deltaz) x \%unit\% u \method{unitname}{default}(x) \method{unitname}{default}(x) <- value unstackFilter(x) \method{update}{im}(object, \dots) validradius(r, caller) validate.mask(w, fatal=TRUE) validate.quad(Q, fatal, repair, announce) versioncurrency.spatstat(today, checkR) versionstring.spatstat() veryunique(z) verifyclass(X, C, N = deparse(substitute(X)), fatal = TRUE) warn.once(key, \dots) warn.no.metric.support(caller, \dots, metric) warn.unsupported.args(unsup, \dots) waxlyrical(type, terse) wrangle2image(values, template) w.quad(Q) x.quad(Q) y.quad(Q) xy.grid(xr, yr, nx, ny, dx, dy) \method{xtfrm}{im}(x) xypolyselfint(p, eps, proper, yesorno, checkinternal) XDtoNN(d, what, iX, iY, k, \dots) xypolygon2psp(p, w, check) ZeroValue(x) \method{ZeroValue}{im}(x) } \details{ These internal \pkg{spatstat.geom} functions should not be called directly by the user. Their names and capabilities may change without warning from one version of \pkg{spatstat.geom} to the next. } \value{ The return values of these functions are not documented, and may change without warning. } \keyword{internal} spatstat.geom/man/texturemap.Rd0000644000176200001440000000323614611065351016311 0ustar liggesusers\name{texturemap} \alias{texturemap} \title{ Texture Map } \description{ Create a map that associates data values with graphical textures. } \usage{ texturemap(inputs, textures, ...) } \arguments{ \item{inputs}{ A vector containing all the data values that will be mapped to textures. } \item{textures}{ Optional. A vector of integer codes specifying the textures to which the \code{inputs} will be mapped. } \item{\dots}{ Other graphics parameters such as \code{col}, \code{lwd}, \code{lty}. } } \details{ A texture map is an association between data values and graphical textures. The command \code{texturemap} creates an object of class \code{"texturemap"} that represents a texture map. Once a texture map has been created, it can be applied to any suitable data to generate a texture plot of those data using \code{\link{textureplot}}. This makes it easy to ensure that the \emph{same} texture map is used in two different plots. The texture map can also be plotted in its own right. The argument \code{inputs} should be a vector containing all the possible data values (such as the levels of a factor) that are to be mapped. The \code{textures} should be integer values between 1 and 8, representing the eight possible textures described in the help for \code{\link{add.texture}}. The default is \code{textures = 1:n} where \code{n} is the length of \code{inputs}. } \value{ An object of class \code{"texturemap"} representing the texture map. } \author{ \spatstatAuthors. } \seealso{ \code{\link{textureplot}} } \examples{ texturemap(letters[1:4], 2:5, col=1:4, lwd=2) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/discpartarea.Rd0000644000176200001440000000370714611065346016564 0ustar liggesusers\name{discpartarea} \Rdversion{1.1} \alias{discpartarea} \title{ Area of Part of Disc } \description{ Compute area of intersection between a disc and a window } \usage{ discpartarea(X, r, W=as.owin(X)) } \arguments{ \item{X}{ Point pattern (object of class \code{"ppp"}) specifying the centres of the discs. Alternatively, \code{X} may be in any format acceptable to \code{\link{as.ppp}}. } \item{r}{ Matrix, vector or numeric value specifying the radii of the discs. } \item{W}{ Window (object of class \code{"owin"}) with which the discs should be intersected. } } \details{ This algorithm computes the exact area of the intersection between a window \code{W} and a disc (or each of several discs). The centres of the discs are specified by the point pattern \code{X}, and their radii are specified by \code{r}. If \code{r} is a single numeric value, then the algorithm computes the area of intersection between \code{W} and the disc of radius \code{r} centred at each point of \code{X}, and returns a one-column matrix containing one entry for each point of \code{X}. If \code{r} is a vector of length \code{m}, then the algorithm returns an \code{n * m} matrix in which the entry on row \code{i}, column \code{j} is the area of the intersection between \code{W} and the disc centred at \code{X[i]} with radius \code{r[j]}. If \code{r} is a matrix, it should have one row for each point in \code{X}. The algorithm returns a matrix in which the entry on row \code{i}, column \code{j} is the area of the intersection between \code{W} and the disc centred at \code{X[i]} with radius \code{r[i,j]}. Areas are computed by analytic geometry. } \value{ Numeric matrix, with one row for each point of \code{X}. } \seealso{ \code{\link{owin}}, \code{\link{disc}} } \examples{ X <- unmark(demopat)[1:3] discpartarea(X, 0.2) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/harmonise.im.Rd0000644000176200001440000000373114611065346016510 0ustar liggesusers\name{harmonise.im} \alias{harmonise.im} \alias{harmonize.im} \title{Make Pixel Images Compatible} \description{ Convert several pixel images to a common pixel raster. } \usage{ \method{harmonise}{im}(\dots) \method{harmonize}{im}(\dots) } \arguments{ \item{\dots}{ Any number of pixel images (objects of class \code{"im"}) or data which can be converted to pixel images by \code{\link{as.im}}. } } \details{ This function makes any number of pixel images compatible, by converting them all to a common pixel grid. The command \code{\link{harmonise}} is generic. This is the method for objects of class \code{"im"}. At least one of the arguments \code{\dots} must be a pixel image. Some arguments may be windows (objects of class \code{"owin"}), functions (\code{function(x,y)}) or numerical constants. These will be converted to images using \code{\link{as.im}}. The common pixel grid is determined by inspecting all the pixel images in the argument list, computing the bounding box of all the images, then finding the image with the highest spatial resolution, and extending its pixel grid to cover the bounding box. The return value is a list with entries corresponding to the input arguments. If the arguments were named (\code{name=value}) then the return value also carries these names. If you just want to determine the appropriate pixel resolution, without converting the images, use \code{\link{commonGrid}}. } \value{ A list, of length equal to the number of arguments \code{\dots}, whose entries are pixel images. } \author{ \adrian and \rolf } \examples{ Image1 <- setcov(square(1), dimyx=32) Image2 <- setcov(square(1), dimyx=16) Function1 <- function(x,y) { x } Window1 <- shift(letterR, c(-2, -1)) h <- harmonise(X=Image1, Y=Image2, Z=Function1, W=Window1) plot(h, main="") } \seealso{ \code{\link{commonGrid}}, \code{\link{compatible.im}}, \code{\link{as.im}} } \keyword{spatial} \keyword{manip} spatstat.geom/man/is.linim.Rd0000644000176200001440000000127214611065351015633 0ustar liggesusers\name{is.linim} \alias{is.linim} \title{Test Whether an Object is a Pixel Image on a Linear Network} \description{ Tests whether its argument is a pixel image on a linear network (object of class \code{"linim"}). } \usage{ is.linim(x) } \arguments{ \item{x}{Any object.} } \details{ This function tests whether the argument \code{x} is a pixel image on a linear network (object of class \code{"linim"}). The object is determined to be an image if it inherits from class \code{"linim"}. } \value{ \code{TRUE} if \code{x} is a pixel image on a linear network, otherwise \code{FALSE}. } \author{ \spatstatAuthors } \keyword{spatial} \keyword{manip} \concept{Linear network} spatstat.geom/man/plot.listof.Rd0000644000176200001440000002206614721742045016376 0ustar liggesusers\name{plot.listof} \alias{plot.listof} \title{Plot a List of Things} \description{ Plots a list of things } \usage{ \method{plot}{listof}(x, \dots, main, arrange=TRUE, nrows=NULL, ncols=NULL, main.panel=NULL, mar.panel=c(2,1,1,2), hsep=0, vsep=0, panel.begin=NULL, panel.end=NULL, panel.args=NULL, panel.begin.args=NULL, panel.end.args=NULL, panel.vpad=0.2, plotcommand="plot", adorn.left=NULL, adorn.right=NULL, adorn.top=NULL, adorn.bottom=NULL, adorn.size=0.2, adorn.args=list(), equal.scales=FALSE, halign=FALSE, valign=FALSE) } \arguments{ \item{x}{ An object of the class \code{"listof"}. Essentially a list of objects. } \item{\dots}{ Arguments passed to \code{\link{plot}} when generating each plot panel. } \item{main}{ Overall heading for the plot. } \item{arrange}{ Logical flag indicating whether to plot the objects side-by-side on a single page (\code{arrange=TRUE}) or plot them individually in a succession of frames (\code{arrange=FALSE}). } \item{nrows,ncols}{ Optional. The number of rows/columns in the plot layout (assuming \code{arrange=TRUE}). You can specify either or both of these numbers. } \item{main.panel}{ Optional. A character string, or a vector of character strings, giving the headings for each of the objects. } \item{mar.panel}{ Size of the margins outside each plot panel. A numeric vector of length 4 giving the bottom, left, top, and right margins in that order. (Alternatively the vector may have length 1 or 2 and will be replicated to length 4). See the section on \emph{Spacing between plots}. } \item{hsep,vsep}{ Additional horizontal and vertical separation between plot panels, expressed in the same units as \code{mar.panel}. } \item{panel.begin,panel.end}{ Optional. Functions that will be executed before and after each panel is plotted. See Details. } \item{panel.args}{ Optional. Function that determines different plot arguments for different panels. See Details. } \item{panel.begin.args}{ Optional. List of additional arguments for \code{panel.begin} when it is a function. } \item{panel.end.args}{ Optional. List of additional arguments for \code{panel.end} when it is a function. } \item{panel.vpad}{ Amount of extra vertical space that should be allowed for the title of each panel, if a title will be displayed. Expressed as a fraction of the height of the panel. Applies only when \code{equal.scales=FALSE} (the default) and requires that the height of each panel can be determined. } \item{plotcommand}{ Optional. Character string containing the name of the command that should be executed to plot each panel. } \item{adorn.left,adorn.right,adorn.top,adorn.bottom}{ Optional. Functions (with no arguments) that will be executed to generate additional plots at the margins (left, right, top and/or bottom, respectively) of the array of plots. } \item{adorn.size}{ Relative width (as a fraction of the other panels' widths) of the margin plots. } \item{adorn.args}{ Optional list of arguments passed to the functions \code{adorn.left}, \code{adorn.right}, \code{adorn.top} and \code{adorn.bottom}. } \item{equal.scales}{ Logical value indicating whether the components should be plotted at (approximately) the same physical scale. } \item{halign,valign}{ Logical values indicating whether panels in a column should be aligned to the same \eqn{x} coordinate system (\code{halign=TRUE}) and whether panels in a row should be aligned to the same \eqn{y} coordinate system (\code{valign=TRUE}). These are applicable only if \code{equal.scales=TRUE}. } } \value{ Null. } \details{ This is the \code{plot} method for the class \code{"listof"}. An object of class \code{"listof"} (defined in the base R package) represents a list of objects, all belonging to a common class. The base R package defines a method for printing these objects, \code{\link[base]{print.listof}}, but does not define a method for \code{plot}. So here we have provided a method for \code{plot}. In the \pkg{spatstat} package, various functions produce an object of class \code{"listof"}, essentially a list of spatial objects of the same kind. These objects can be plotted in a nice arrangement using \code{plot.listof}. See the Examples. The argument \code{panel.args} determines extra graphics parameters for each panel. It should be a function that will be called as \code{panel.args(i)} where \code{i} is the panel number. Its return value should be a list of graphics parameters that can be passed to the relevant \code{plot} method. These parameters override any parameters specified in the \code{\dots} arguments. The arguments \code{panel.begin} and \code{panel.end} determine graphics that will be plotted before and after each panel is plotted. They may be objects of some class that can be plotted with the generic \code{plot} command. Alternatively they may be functions that will be called as \code{panel.begin(i, y, main=main.panel[i])} and \code{panel.end(i, y, add=TRUE)} where \code{i} is the panel number and \code{y = x[[i]]}. If all entries of \code{x} are pixel images, the function \code{\link{image.listof}} is called to control the plotting. The arguments \code{equal.ribbon} and \code{col} can be used to determine the colour map or maps applied. If \code{equal.scales=FALSE} (the default), then the plot panels will have equal height on the plot device (unless there is only one column of panels, in which case they will have equal width on the plot device). This means that the objects are plotted at different physical scales, by default. If \code{equal.scales=TRUE}, then the dimensions of the plot panels on the plot device will be proportional to the spatial dimensions of the corresponding components of \code{x}. This means that the objects will be plotted at \emph{approximately} equal physical scales. If these objects have very different spatial sizes, the plot command could fail (when it tries to plot the smaller objects at a tiny scale), with an error message that the figure margins are too large. The objects will be plotted at \emph{exactly} equal physical scales, and \emph{exactly} aligned on the device, under the following conditions: \itemize{ \item every component of \code{x} is a spatial object whose position can be shifted by \code{\link{shift}}; \item \code{panel.begin} and \code{panel.end} are either \code{NULL} or they are spatial objects whose position can be shifted by \code{\link{shift}}; \item \code{adorn.left}, \code{adorn.right}, \code{adorn.top} and \code{adorn.bottom} are all \code{NULL}. } Another special case is when every component of \code{x} is an object of class \code{"fv"} representing a function. If \code{equal.scales=TRUE} then all these functions will be plotted with the same axis scales (i.e. with the same \code{xlim} and the same \code{ylim}). } \section{Spacing between plots}{ The spacing between individual plots is controlled by the parameters \code{mar.panel}, \code{hsep} and \code{vsep}. If \code{equal.scales=FALSE}, the plot panels are logically separate plots. The margins for each panel are determined by the argument \code{mar.panel} which becomes the graphics parameter \code{mar} described in the help file for \code{\link{par}}. One unit of \code{mar} corresponds to one line of text in the margin. If \code{hsep} or \code{vsep} are present, \code{mar.panel} is augmented by \code{c(vsep, hsep, vsep, hsep)/2}. If \code{equal.scales=TRUE}, all the plot panels are drawn in the same coordinate system which represents a physical scale. The unit of measurement for \code{mar.panel[1,3]} is one-sixth of the greatest height of any object plotted in the same row of panels, and the unit for \code{mar.panel[2,4]} is one-sixth of the greatest width of any object plotted in the same column of panels. If \code{hsep} or \code{vsep} are present, they are interpreted in the same units as \code{mar.panel[2]} and \code{mar.panel[1]} respectively. } \seealso{ \code{\link[base]{print.listof}}, \code{\link{contour.listof}}, \code{\link{image.listof}}, \code{\link[spatstat.explore]{density.splitppp}} } \section{Error messages}{ If the error message \sQuote{Figure margins too large} occurs, this generally means that one of the objects had a much smaller physical scale than the others. Ensure that \code{equal.scales=FALSE} and increase the values of \code{mar.panel}. } \examples{ D <- solapply(split(mucosa), distfun) plot(D) plot(D, main="", equal.ribbon=TRUE, panel.end=function(i,y,...){contour(y, ..., drawlabels=FALSE)}) # list of 3D point patterns ape1 <- osteo[osteo$shortid==4, "pts", drop=TRUE] class(ape1) plot(ape1, main.panel="", mar.panel=0.1, hsep=0.7, vsep=1, cex=1.5, pch=21, bg='white') } \author{ \adrian and \rolf } \keyword{spatial} \keyword{hplot} spatstat.geom/man/crossdist.ppx.Rd0000644000176200001440000000335414611065345016742 0ustar liggesusers\name{crossdist.ppx} \alias{crossdist.ppx} \title{Pairwise Distances Between Two Different Multi-Dimensional Point Patterns} \description{ Computes the distances between pairs of points taken from two different multi-dimensional point patterns. } \usage{ \method{crossdist}{ppx}(X, Y, \dots) } \arguments{ \item{X,Y}{ Multi-dimensional point patterns (objects of class \code{"ppx"}). } \item{\dots}{ Arguments passed to \code{\link{coords.ppx}} to determine which coordinates should be used. } } \value{ A matrix whose \code{[i,j]} entry is the distance from the \code{i}-th point in \code{X} to the \code{j}-th point in \code{Y}. } \details{ Given two point patterns in multi-dimensional space, this function computes the Euclidean distance from each point in the first pattern to each point in the second pattern, and returns a matrix containing these distances. This is a method for the generic function \code{\link{crossdist}} for three-dimensional point patterns (objects of class \code{"ppx"}). This function expects two multidimensional point patterns \code{X} and \code{Y}, and returns the matrix whose \code{[i,j]} entry is the distance from \code{X[i]} to \code{Y[j]}. By default, both spatial and temporal coordinates are extracted. To obtain the spatial distance between points in a space-time point pattern, set \code{temporal=FALSE}. } \seealso{ \code{\link{crossdist}}, \code{\link{pairdist}}, \code{\link{nndist}} } \examples{ df <- data.frame(x=runif(3),y=runif(3),z=runif(3),w=runif(3)) X <- ppx(data=df) df <- data.frame(x=runif(5),y=runif(5),z=runif(5),w=runif(5)) Y <- ppx(data=df) d <- crossdist(X, Y) } \author{ \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/summary.ppp.Rd0000644000176200001440000000311014611065350016374 0ustar liggesusers\name{summary.ppp} \alias{summary.ppp} \title{Summary of a Point Pattern Dataset} \description{ Prints a useful summary of a point pattern dataset. } \usage{ \method{summary}{ppp}(object, \dots, checkdup=TRUE) } \arguments{ \item{object}{ Point pattern (object of class \code{"ppp"}). } \item{\dots}{ Ignored. } \item{checkdup}{ Logical value indicating whether to check for the presence of duplicate points. } } \details{ A useful summary of the point pattern \code{object} is printed. This is a method for the generic function \code{\link{summary}}. If \code{checkdup=TRUE}, the pattern will be checked for the presence of duplicate points, using \code{\link{duplicated.ppp}}. This can be time-consuming if the pattern contains many points, so the checking can be disabled by setting \code{checkdup=FALSE}. If the point pattern was generated by simulation using \code{\link[spatstat.random]{rmh}}, the parameters of the algorithm are printed. } \seealso{ \code{\link{summary}}, \code{\link{summary.owin}}, \code{\link{print.ppp}} } \examples{ summary(cells) # plain vanilla point pattern # multitype point pattern woods <- lansing \testonly{woods <- woods[seq(1, npoints(woods), length=40)]} summary(woods) # tabulates frequencies of each mark # numeric marks trees <- longleaf \testonly{trees <- trees[seq(1, npoints(trees), length=40)]} summary(trees) # prints summary.default(marks(trees)) # weird polygonal window summary(demopat) # describes it } \author{ \spatstatAuthors } \keyword{spatial} \keyword{methods} spatstat.geom/man/fardist.Rd0000644000176200001440000000273614643111575015560 0ustar liggesusers\name{fardist} \alias{fardist} \alias{fardist.ppp} \alias{fardist.owin} \title{ Farthest Distance to Boundary of Window } \description{ Computes the farthest distance from each pixel, or each data point, to the boundary of the window. } \usage{ fardist(X, \dots) \method{fardist}{owin}(X, \dots, squared=FALSE) \method{fardist}{ppp}(X, \dots, squared=FALSE) } \arguments{ \item{X}{ A spatial object such as a window or point pattern. } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution, if required. } \item{squared}{ Logical. If \code{TRUE}, the squared distances will be returned. } } \details{ The function \code{fardist} is generic, with methods for the classes \code{owin} and \code{ppp}. For a window \code{W}, the command \code{fardist(W)} returns a pixel image in which the value at each pixel is the \emph{largest} distance from that pixel to the boundary of \code{W}. For a point pattern \code{X}, with window \code{W}, the command \code{fardist(X)} returns a numeric vector with one entry for each point of \code{X}, giving the largest distance from that data point to the boundary of \code{W}. } \value{ For \code{fardist.owin}, a pixel image (object of class \code{"im"}). For \code{fardist.ppp}, a numeric vector. } \examples{ fardist(cells) plot(FR <- fardist(letterR)) } \author{\adrian \rolf and \ege } \keyword{spatial} \keyword{math} spatstat.geom/man/add.texture.Rd0000644000176200001440000000313714611065345016345 0ustar liggesusers\name{add.texture} \alias{add.texture} \title{ Fill Plot With Texture } \description{ Draws a simple texture inside a region on the plot. } \usage{ add.texture(W, texture = 4, spacing = NULL, ...) } \arguments{ \item{W}{ Window (object of class \code{"owin"}) inside which the texture should be drawn. } \item{texture}{ Integer from 1 to 8 identifying the type of texture. See Details. } \item{spacing}{ Spacing between elements of the texture, in units of the current plot. } \item{\dots}{ Further arguments controlling the plot colour, line width etc. } } \details{ The chosen texture, confined to the window \code{W}, will be added to the current plot. The available textures are: \describe{ \item{texture=1:}{ Small crosses arranged in a square grid. } \item{texture=2:}{ Parallel vertical lines. } \item{texture=3:}{ Parallel horizontal lines. } \item{texture=4:}{ Parallel diagonal lines at 45 degrees from the horizontal. } \item{texture=5:}{ Parallel diagonal lines at 135 degrees from the horizontal. } \item{texture=6:}{ Grid of horizontal and vertical lines. } \item{texture=7:}{ Grid of diagonal lines at 45 and 135 degrees from the horizontal. } \item{texture=8:}{ Grid of hexagons. } } } \author{ \adrian and \rolf } \seealso{ \code{\link{owin}}, \code{\link{plot.owin}}, \code{\link{textureplot}}, \code{\link{texturemap}}. } \examples{ W <- Window(chorley) plot(W, main="") add.texture(W, 7) } \keyword{spatial} \keyword{hplot} spatstat.geom/man/closing.Rd0000644000176200001440000000471614643111575015562 0ustar liggesusers\name{closing} \alias{closing} \alias{closing.owin} \alias{closing.ppp} \alias{closing.psp} \title{Morphological Closing} \description{ Perform morphological closing of a window, a line segment pattern or a point pattern. } \usage{ closing(w, r, \dots) \method{closing}{owin}(w, r, \dots, polygonal=NULL) \method{closing}{ppp}(w, r, \dots, polygonal=TRUE) \method{closing}{psp}(w, r, \dots, polygonal=TRUE) } \arguments{ \item{w}{ A window (object of class \code{"owin"} or a line segment pattern (object of class \code{"psp"}) or a point pattern (object of class \code{"ppp"}). } \item{r}{positive number: the radius of the closing.} \item{\dots}{extra arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution, if a pixel approximation is used} \item{polygonal}{ Logical flag indicating whether to compute a polygonal approximation to the erosion (\code{polygonal=TRUE}) or a pixel grid approximation (\code{polygonal=FALSE}). } } \value{ If \code{r > 0}, an object of class \code{"owin"} representing the closed region. If \code{r=0}, the result is identical to \code{w}. } \details{ The morphological closing (Serra, 1982) of a set \eqn{W} by a distance \eqn{r > 0} is the set of all points that cannot be separated from \eqn{W} by any circle of radius \eqn{r}. That is, a point \eqn{x} belongs to the closing \eqn{W*} if it is impossible to draw any circle of radius \eqn{r} that has \eqn{x} on the inside and \eqn{W} on the outside. The closing \eqn{W*} contains the original set \eqn{W}. For a small radius \eqn{r}, the closing operation has the effect of smoothing out irregularities in the boundary of \eqn{W}. For larger radii, the closing operation smooths out concave features in the boundary. For very large radii, the closed set \eqn{W*} becomes more and more convex. The algorithm applies \code{\link{dilation}} followed by \code{\link{erosion}}. } \seealso{ \code{\link{opening}} for the opposite operation. \code{\link{dilation}}, \code{\link{erosion}} for the basic operations. \code{\link{owin}}, \code{\link{as.owin}} for information about windows. } \examples{ v <- closing(letterR, 0.25) plot(v, main="closing") plot(letterR, add=TRUE) plot(closing(cells, 0.1)) points(cells) } \references{ Serra, J. (1982) Image analysis and mathematical morphology. Academic Press. } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{math} spatstat.geom/man/nncross.pp3.Rd0000644000176200001440000001461614611065347016312 0ustar liggesusers\name{nncross.pp3} \alias{nncross.pp3} \title{Nearest Neighbours Between Two Patterns in 3D} \description{ Given two point patterns \code{X} and \code{Y} in three dimensions, finds the nearest neighbour in \code{Y} of each point of \code{X}. } \usage{ \method{nncross}{pp3}(X, Y, iX=NULL, iY=NULL, what = c("dist", "which"), \dots, k = 1, sortby=c("range", "var", "x", "y", "z"), is.sorted.X = FALSE, is.sorted.Y = FALSE) } \arguments{ \item{X,Y}{Point patterns in three dimensions (objects of class \code{"pp3"}).} \item{iX, iY}{Optional identifiers, used to determine whether a point in \code{X} is identical to a point in \code{Y}. See Details. } \item{what}{ Character string specifying what information should be returned. Either the nearest neighbour distance (\code{"dist"}), the identifier of the nearest neighbour (\code{"which"}), or both. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } \item{sortby}{ Determines which coordinate to use to sort the point patterns. See Details. } \item{is.sorted.X, is.sorted.Y}{ Logical values attesting whether the point patterns \code{X} and \code{Y} have been sorted. See Details. } \item{\dots}{Ignored.} } \details{ Given two point patterns \code{X} and \code{Y} in three dimensions, this function finds, for each point of \code{X}, the nearest point of \code{Y}. The distance between these points is also computed. If the argument \code{k} is specified, then the \code{k}-th nearest neighbours will be found. The return value is a data frame, with rows corresponding to the points of \code{X}. The first column gives the nearest neighbour distances (i.e. the \code{i}th entry is the distance from the \code{i}th point of \code{X} to the nearest element of \code{Y}). The second column gives the indices of the nearest neighbours (i.e.\ the \code{i}th entry is the index of the nearest element in \code{Y}.) If \code{what="dist"} then only the vector of distances is returned. If \code{what="which"} then only the vector of indices is returned. The argument \code{k} may be an integer or an integer vector. If it is a single integer, then the \code{k}-th nearest neighbours are computed. If it is a vector, then the \code{k[i]}-th nearest neighbours are computed for each entry \code{k[i]}. For example, setting \code{k=1:3} will compute the nearest, second-nearest and third-nearest neighbours. The result is a data frame. Note that this function is not symmetric in \code{X} and \code{Y}. To find the nearest neighbour in \code{X} of each point in \code{Y}, use \code{nncross(Y,X)}. The arguments \code{iX} and \code{iY} are used when the two point patterns \code{X} and \code{Y} have some points in common. In this situation \code{nncross(X, Y)} would return some zero distances. To avoid this, attach a unique integer identifier to each point, such that two points are identical if their identifying numbers are equal. Let \code{iX} be the vector of identifier values for the points in \code{X}, and \code{iY} the vector of identifiers for points in \code{Y}. Then the code will only compare two points if they have different values of the identifier. See the Examples. } \section{Sorting data and pre-sorted data}{ Read this section if you care about the speed of computation. For efficiency, the algorithm sorts both the point patterns \code{X} and \code{Y} into increasing order of the \eqn{x} coordinate, or both into increasing order of the \eqn{y} coordinate, or both into increasing order of the \eqn{z} coordinate. Sorting is only an intermediate step; it does not affect the output, which is always given in the same order as the original data. By default (if \code{sortby="range"}), the sorting will occur on the coordinate that has the largest range of values (according to the frame of the enclosing window of \code{Y}). If \code{sortby = "var"}), sorting will occur on the coordinate that has the greater variance (in the pattern \code{Y}). Setting \code{sortby="x"} or \code{sortby = "y"} or \code{sortby = "z"} will specify that sorting should occur on the \eqn{x}, \eqn{y} or \eqn{z} coordinate, respectively. If the point pattern \code{X} is already sorted, then the corresponding argument \code{is.sorted.X} should be set to \code{TRUE}, and \code{sortby} should be set equal to \code{"x"}, \code{"y"} or \code{"z"} to indicate which coordinate is sorted. Similarly if \code{Y} is already sorted, then \code{is.sorted.Y} should be set to \code{TRUE}, and \code{sortby} should be set equal to \code{"x"}, \code{"y"} or \code{"z"} to indicate which coordinate is sorted. If both \code{X} and \code{Y} are sorted \emph{on the same coordinate axis} then both \code{is.sorted.X} and \code{is.sorted.Y} should be set to \code{TRUE}, and \code{sortby} should be set equal to \code{"x"}, \code{"y"} or \code{"z"} to indicate which coordinate is sorted. } \value{ A data frame, or a vector if the data frame would contain only one column. By default (if \code{what=c("dist", "which")} and \code{k=1}) a data frame with two columns: \item{dist}{Nearest neighbour distance} \item{which}{Nearest neighbour index in \code{Y}} If \code{what="dist"} and \code{k=1}, a vector of nearest neighbour distances. If \code{what="which"} and \code{k=1}, a vector of nearest neighbour indices. If \code{k} is specified, the result is a data frame with columns containing the \code{k}-th nearest neighbour distances and/or nearest neighbour indices. } \seealso{ \code{\link{nndist}} for nearest neighbour distances in a single point pattern. } \examples{ # two different point patterns X <- pp3(runif(10), runif(10), runif(10), box3(c(0,1))) Y <- pp3(runif(20), runif(20), runif(20), box3(c(0,1))) N <- nncross(X,Y)$which N <- nncross(X,Y, what="which") #faster # note that length(N) = 10 # k-nearest neighbours N3 <- nncross(X, Y, k=1:3) # two patterns with some points in common Z <- pp3(runif(20), runif(20), runif(20), box3(c(0,1))) X <- Z[1:15] Y <- Z[10:20] iX <- 1:15 iY <- 10:20 N <- nncross(X,Y, iX, iY, what="which") } \author{ \adrian , \rolf , and Jens Oehlschlaegel } \keyword{spatial} \keyword{math} \concept{Three-dimensional} spatstat.geom/man/perspPoints.Rd0000644000176200001440000000632714611065347016452 0ustar liggesusers\name{perspPoints} \alias{perspPoints} \alias{perspSegments} \alias{perspLines} \alias{perspContour} \title{ Draw Points or Lines on a Surface Viewed in Perspective } \description{ After a surface has been plotted in a perspective view using \code{\link{persp.im}}, these functions can be used to draw points or lines on the surface. } \usage{ perspPoints(x, y=NULL, \dots, Z, M, occluded=TRUE) perspLines(x, y = NULL, \dots, Z, M, occluded=TRUE) perspSegments(x0, y0 = NULL, x1 = NULL, y1 = NULL, \dots, Z, M, occluded=TRUE) perspContour(Z, M, \dots, nlevels=10, levels=pretty(range(Z), nlevels), occluded=TRUE) } \arguments{ \item{x,y}{ Spatial coordinates, acceptable to \code{\link[grDevices]{xy.coords}}, for the points or lines on the horizontal plane. } \item{Z}{ Pixel image (object of class \code{"im"}) specifying the surface heights. } \item{M}{ Projection matrix returned from \code{\link{persp.im}} when \code{Z} was plotted. } \item{\dots}{ Graphical arguments passed to \code{\link[graphics]{points}}, \code{\link[graphics]{lines}} or \code{\link[graphics]{segments}} to control the drawing. } \item{x0,y0,x1,y1}{ Spatial coordinates of the line segments, on the horizontal plane. Alternatively \code{x0} can be a line segment pattern (object of class \code{"psp"}) and \code{y0,x1,y1} can be \code{NULL}. } \item{nlevels}{Number of contour levels} \item{levels}{Vector of heights of contours.} \item{occluded}{ Logical value specifying whether parts of the surface can be obscured by other parts of the surface. See Details. } } \details{ After a surface has been plotted in a perspective view, these functions can be used to draw points or lines on the surface. The user should already have called \code{\link{persp.im}} to display the perspective view of the surface \code{Z} and to obtain the perspective matrix \code{M} by typing \code{M <- persp(Z, ...)}. The points and lines will be drawn in their correct three-dimensional position according to the same perspective. If \code{occluded=TRUE} (the default), then the surface is treated as if it were opaque. The code will draw only those points and lines which are visible from the viewer's standpoint, and not obscured by other parts of the surface lying closer to the viewer. The user should already have called \code{\link{persp.im}} in the form \code{M <- persp(Z, visible=TRUE, ...)} to compute the visibility information. If \code{occluded=FALSE}, then the surface is treated as if it were transparent. All the specified points and lines will be drawn on the surface. } \value{ Same as the return value from \code{\link[graphics]{points}} or \code{\link[graphics]{segments}}. } \seealso{ \code{\link{persp.im}} } \examples{ M <- persp(bei.extra$elev, colmap=terrain.colors(128), apron=TRUE, theta=-30, phi=20, zlab="Elevation", main="", expand=6, visible=TRUE, shade=0.3) perspContour(bei.extra$elev, M=M, col="pink", nlevels=12) perspPoints(bei, Z=bei.extra$elev, M=M, pch=16, cex=0.3, col="chartreuse") } \author{ \spatstatAuthors } \keyword{spatial} \keyword{hplot} spatstat.geom/man/identify.ppp.Rd0000644000176200001440000000332714611065346016531 0ustar liggesusers\name{identify.ppp} \alias{identify.ppp} \title{Identify Points in a Point Pattern} \description{ If a point pattern is plotted in the graphics window, this function will find the point of the pattern which is nearest to the mouse position, and print its mark value (or its serial number if there is no mark). } \usage{ \method{identify}{ppp}(x, \dots) } \arguments{ \item{x}{ A point pattern (object of class \code{"ppp"}). } \item{\dots}{ Arguments passed to \code{\link[graphics]{identify.default}}. } } \value{ If \code{x} is unmarked, the result is a vector containing the serial numbers of the points in the pattern \code{x} that were identified. If \code{x} is marked, the result is a 2-column matrix, the first column containing the serial numbers and the second containing the marks for these points. } \details{ This is a method for the generic function \code{\link[graphics]{identify}} for point pattern objects. The point pattern \code{x} should first be plotted using \code{\link{plot.ppp}}. Then \code{identify(x)} reads the position of the graphics pointer each time the left mouse button is pressed. It then finds the point of the pattern \code{x} closest to the mouse position. If this closest point is sufficiently close to the mouse pointer, its index (and its mark if any) will be returned as part of the value of the call. Each time a point of the pattern is identified, text will be displayed next to the point, showing its serial number (if \code{x} is unmarked) or its mark value (if \code{x} is marked). } \seealso{ \code{\link[graphics]{identify}}, \code{\link{clickppp}} } \author{ \adrian and \rolf } \keyword{spatial} \keyword{iplot} spatstat.geom/man/eval.im.Rd0000644000176200001440000000606114611065346015451 0ustar liggesusers\name{eval.im} \alias{eval.im} \title{Evaluate Expression Involving Pixel Images} \description{ Evaluates any expression involving one or more pixel images, and returns a pixel image. } \usage{ eval.im(expr, envir, harmonize=TRUE, warn=TRUE) } \arguments{ \item{expr}{An expression.} \item{envir}{Optional. The environment in which to evaluate the expression, or a named list containing pixel images to be used in the expression.} \item{harmonize}{ Logical. Whether to resolve inconsistencies between the pixel grids. } \item{warn}{ Logical. Whether to issue a warning if the pixel grids were inconsistent. } } \details{ This function is a wrapper to make it easier to perform pixel-by-pixel calculations in an image. Pixel images in \pkg{spatstat} are represented by objects of class \code{"im"} (see \code{\link{im.object}}). These are essentially matrices of pixel values, with extra attributes recording the pixel dimensions, etc. Suppose \code{X} is a pixel image. Then \code{eval.im(X+3)} will add 3 to the value of every pixel in \code{X}, and return the resulting pixel image. Suppose \code{X} and \code{Y} are two pixel images with compatible dimensions: they have the same number of pixels, the same physical size of pixels, and the same bounding box. Then \code{eval.im(X + Y)} will add the corresponding pixel values in \code{X} and \code{Y}, and return the resulting pixel image. In general, \code{expr} can be any expression in the R language involving (a) the \emph{names} of pixel images, (b) scalar constants, and (c) functions which are vectorised. See the Examples. First \code{eval.im} determines which of the \emph{variable names} in the expression \code{expr} refer to pixel images. Each such name is replaced by a matrix containing the pixel values. The expression is then evaluated. The result should be a matrix; it is taken as the matrix of pixel values. The expression \code{expr} must be vectorised. There must be at least one pixel image in the expression. All images must have compatible dimensions. If \code{harmonize=FALSE}, images that are incompatible will cause an error. If \code{harmonize=TRUE}, images that have incompatible dimensions will be resampled so that they are compatible; if \code{warn=TRUE}, a warning will be issued. } \value{ An image object of class \code{"im"}. } \seealso{ \code{\link{im.apply}} for operations similar to \code{\link{apply}}, such as taking the sum of a list of images. \code{\link{as.im}}, \code{\link{compatible.im}}, \code{\link{harmonise.im}}, \code{\link{im.object}} } \examples{ # test images X <- as.im(function(x,y) { x^2 - y^2 }, unit.square()) Y <- as.im(function(x,y) { 3 * x + y }, unit.square()) eval.im(X + 3) eval.im(X - Y) eval.im(abs(X - Y)) Z <- eval.im(sin(X * pi) + Y) ## Use of 'envir': bei.extra is a list with components 'elev' and 'grad' W <- eval.im(atan(grad) * 180/pi, bei.extra) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} \keyword{programming} spatstat.geom/man/convolve.im.Rd0000644000176200001440000000467714611065345016367 0ustar liggesusers\name{convolve.im} \alias{convolve.im} \title{Convolution of Pixel Images} \description{ Computes the convolution of two pixel images. } \usage{ convolve.im(X, Y=X, \dots, reflectX=FALSE, reflectY=FALSE) } \arguments{ \item{X}{ A pixel image (object of class \code{"im"}. } \item{Y}{ Optional. Another pixel image. } \item{\dots}{Ignored.} \item{reflectX,reflectY}{ Logical values specifying whether the images \code{X} and \code{Y} (respectively) should be reflected in the origin before computing the convolution. } } \value{ A pixel image (an object of class \code{"im"}) representing the convolution of \code{X} and \code{Y}. } \details{ The \emph{convolution} of two pixel images \eqn{X} and \eqn{Y} in the plane is the function \eqn{C(v)} defined for each vector \eqn{v} as \deqn{ C(v) = \int X(u)Y(v-u)\, {\rm d}u }{ C(v) = integral of X(u) * Y(v-u) du } where the integral is over all spatial locations \eqn{u}, and where \eqn{X(u)} and \eqn{Y(u)} denote the pixel values of \eqn{X} and \eqn{Y} respectively at location \eqn{u}. This command computes a discretised approximation to the convolution, using the Fast Fourier Transform. The return value is another pixel image (object of class \code{"im"}) whose greyscale values are values of the convolution. If \code{reflectX = TRUE} then the pixel image \code{X} is reflected in the origin (see \code{\link{reflect}}) before the convolution is computed, so that \code{convolve.im(X,Y,reflectX=TRUE)} is mathematically equivalent to \code{convolve.im(reflect(X), Y)}. (These two commands are not exactly equivalent, because the reflection is performed in the Fourier domain in the first command, and reflection is performed in the spatial domain in the second command). Similarly if \code{reflectY = TRUE} then the pixel image \code{Y} is reflected in the origin before the convolution is computed, so that \code{convolve.im(X,Y,reflectY=TRUE)} is mathematically equivalent to \code{convolve.im(X, reflect(Y))}. } \seealso{ \code{\link{imcov}}, \code{\link{reflect}} } \examples{ if(interactive()) { X <- as.im(letterR) Y <- as.im(square(1)) } else { ## coarser image for testing X <- as.im(letterR, dimyx=32) Y <- as.im(square(1), dimyx=32) } plot(convolve.im(X, Y)) plot(convolve.im(X, Y, reflectX=TRUE)) plot(convolve.im(X)) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/midpoints.psp.Rd0000644000176200001440000000142314611065347016723 0ustar liggesusers\name{midpoints.psp} \alias{midpoints.psp} \title{Midpoints of Line Segment Pattern} \description{ Computes the midpoints of each line segment in a line segment pattern. } \usage{ midpoints.psp(x) } \arguments{ \item{x}{ A line segment pattern (object of class \code{"psp"}). } } \value{ Point pattern (object of class \code{"ppp"}). } \details{ The midpoint of each line segment is computed. } \seealso{ \code{\link{marks.psp}}, \code{\link{summary.psp}}, \code{\link{lengths_psp}} \code{\link{angles.psp}}, \code{\link{endpoints.psp}}, \code{\link{extrapolate.psp}}. } \examples{ a <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) b <- midpoints.psp(a) } \author{ \adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/distmap.Rd0000644000176200001440000000367314742317357015574 0ustar liggesusers\name{distmap} \alias{distmap} \title{ Distance Map } \description{ Compute the distance map of an object, and return it as a pixel image. Generic. } \usage{ distmap(X, \dots) } \arguments{ \item{X}{Any suitable dataset representing a two-dimensional object, such as a point pattern (object of class \code{"ppp"}), a window (object of class \code{"owin"}) or a line segment pattern (object of class \code{"psp"}). } \item{\dots}{Arguments passed to \code{\link[spatstat.geom]{as.mask}} to control pixel resolution. } } \value{ A pixel image (object of class \code{"im"}) whose grey scale values are the values of the distance map. } \details{ The \dQuote{distance map} of a set of points \eqn{A} is the function \eqn{f} whose value \code{f(x)} is defined for any two-dimensional location \eqn{x} as the shortest distance from \eqn{x} to \eqn{A}. This function computes the distance map of the set \code{X} and returns the distance map as a pixel image. This is generic. Methods are provided for point patterns (\code{\link{distmap.ppp}}), line segment patterns (\code{\link{distmap.psp}}) and windows (\code{\link{distmap.owin}}) as well as other classes. } \section{Distance values}{ The pixel values in the image \code{distmap(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values in \code{distmap(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{distmap.ppp}}, \code{\link{distmap.psp}}, \code{\link{distmap.owin}}, \code{\link{distfun}} } \examples{ U <- distmap(cells) V <- distmap(letterR) if(interactive()) { plot(U) plot(V) } } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/polartess.Rd0000644000176200001440000000722514611065350016130 0ustar liggesusers\name{polartess} \alias{polartess} \title{ Tessellation Using Polar Coordinates } \description{ Create a tessellation with tiles defined by polar coordinates (radius and angle). } \usage{ polartess(W, \dots, nradial = NULL, nangular = NULL, radii = NULL, angles = NULL, origin = NULL, sep = "x") } \arguments{ \item{W}{ A window (object of class \code{"owin"}) or anything that can be coerced to a window using \code{\link{as.owin}}, such as a point pattern. } \item{\dots}{ Ignored. } \item{nradial}{ Number of \emph{tiles} in the radial direction. A single integer. Ignored if \code{radii} is given. } \item{nangular}{ Number of \emph{tiles} in the angular coordinate. A single integer. Ignored if \code{angles} is given. } \item{radii}{ The numeric values of the radii, defining the tiles in the radial direction. A numeric vector, of length at least 2, containing nonnegative numbers in increasing order. The value \code{Inf} is permitted. } \item{angles}{ The numeric values of the angles defining the tiles in the angular coordinate. A numeric vector, of length at least 2, in increasing order, containing angles in radians. } \item{origin}{ Location to be used as the origin of the polar coordinates. Either a numeric vector of length 2 giving the spatial location of the origin, or one of the strings \code{"centroid"}, \code{"midpoint"}, \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}, \code{"topleft"}, \code{"bottomleft"}, \code{"topright"} or \code{"bottomright"} indicating the location in the window. } \item{sep}{ Argument passed to \code{\link{intersect.tess}} specifying the character string to be used as a separator when forming the names of the tiles. } } \details{ A tessellation will be formed from tiles defined by intervals in the polar coordinates \eqn{r} (radial distance from the origin) or \eqn{\theta} (angle from the horizontal axis) or both. These tiles look like the cells on a dartboard. If the argument \code{radii} is given, tiles will be demarcated by circles centred at the origin, with the specified radii. If \code{radii} is absent but \code{nradial} is given, then \code{radii} will default to a sequence of \code{nradial+1} radii equally spaced from zero to the maximum possible radius. If neither \code{radii} nor \code{nradial} are given, the tessellation will not include circular arc boundaries. If the argument \code{angles} is given, tiles will be demarcated by lines emanating from the origin at the specified angles. The angular values can be any real numbers; they will be interpreted as angles in radians modulo \code{2*pi}, but they must be an increasing sequence of numbers. If \code{angles} is absent but \code{nangular} is given, then \code{angles} will default to a sequence of \code{nangular+1} angles equally spaced from 0 to \code{2*pi}. If neither \code{angles} nor \code{nangular} are given, the tessellation will not include linear boundaries. } \value{ A tessellation (object of class \code{"tess"}). } \author{ \adrian. } \seealso{ \code{\link{intersect.tess}} To construct other kinds of tessellations, see \code{\link{tess}}, \code{\link{quadrats}}, \code{\link{hextess}}, \code{\link{venn.tess}}, \code{\link{dirichlet}}, \code{\link{delaunay}}, \code{\link{quantess}}, \code{\link{bufftess}} and \code{\link[spatstat.random]{rpoislinetess}}. } \examples{ Y <- c(2.8, 1.5) plot(polartess(letterR, nangular=6, radii=(0:4)/2, origin=Y), do.col=TRUE) } \keyword{spatial} \keyword{manip} \concept{Tessellation} spatstat.geom/man/nnwhich.Rd0000644000176200001440000001363414611065347015561 0ustar liggesusers\name{nnwhich} \alias{nnwhich} \alias{nnwhich.ppp} \alias{nnwhich.default} \title{Nearest neighbour} \description{ Finds the nearest neighbour of each point in a point pattern. } \usage{ nnwhich(X, \dots) \method{nnwhich}{ppp}(X, \dots, k=1, by=NULL, method="C", metric=NULL) \method{nnwhich}{default}(X, Y=NULL, \dots, k=1, by=NULL, method="C") } \arguments{ \item{X,Y}{ Arguments specifying the locations of a set of points. For \code{nnwhich.ppp}, the argument \code{X} should be a point pattern (object of class \code{"ppp"}). For \code{nnwhich.default}, typically \code{X} and \code{Y} would be numeric vectors of equal length. Alternatively \code{Y} may be omitted and \code{X} may be a list with two components \code{x} and \code{y}, or a matrix with two columns. } \item{\dots}{ Ignored by \code{nnwhich.ppp} and \code{nnwhich.default}. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } \item{by}{ Optional. A factor, which separates \code{X} into groups. The algorithm will find the nearest neighbour in each group. See Details. } \item{method}{String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. } \item{metric}{ Optional. A metric (object of class \code{"metric"}) that will be used to define and compute the distances. } } \value{ Numeric vector or matrix giving, for each point, the index of its nearest neighbour (or \code{k}th nearest neighbour). If \code{k = 1} (the default), the return value is a numeric vector \code{v} giving the indices of the nearest neighbours (the nearest neighbout of the \code{i}th point is the \code{j}th point where \code{j = v[i]}). If \code{k} is a single integer, then the return value is a numeric vector giving the indices of the \code{k}th nearest neighbours. If \code{k} is a vector, then the return value is a matrix \code{m} such that \code{m[i,j]} is the index of the \code{k[j]}th nearest neighbour for the \code{i}th data point. If the argument \code{by} is given, then it should be a \code{factor} which separates \code{X} into groups (or any type of data acceptable to \code{\link{split.ppp}} that determines the grouping). The result is a data frame containing the indices described above, from each point of \code{X}, to the nearest point in each subset of \code{X} defined by the factor \code{by}. } \details{ For each point in the given point pattern, this function finds its nearest neighbour (the nearest other point of the pattern). By default it returns a vector giving, for each point, the index of the point's nearest neighbour. If \code{k} is specified, the algorithm finds each point's \code{k}th nearest neighbour. The function \code{nnwhich} is generic, with method for point patterns (objects of class \code{"ppp"}) and a default method which are described here, as well as a method for three-dimensional point patterns (objects of class \code{"pp3"}, described in \code{\link{nnwhich.pp3}}. The method \code{nnwhich.ppp} expects a single point pattern argument \code{X}. The default method expects that \code{X} and \code{Y} will determine the coordinates of a set of points. Typically \code{X} and \code{Y} would be numeric vectors of equal length. Alternatively \code{Y} may be omitted and \code{X} may be a list with two components named \code{x} and \code{y}, or a matrix or data frame with two columns. The argument \code{k} may be a single integer, or an integer vector. If it is a vector, then the \eqn{k}th nearest neighbour distances are computed for each value of \eqn{k} specified in the vector. If the argument \code{by} is given, it should be a \code{factor}, of length equal to the number of points in \code{X}. This factor effectively partitions \code{X} into subsets, each subset associated with one of the levels of \code{X}. The algorithm will then find, for each point of \code{X}, the nearest neighbour \emph{in each subset}. If there are no points (if \code{x} has length zero) a numeric vector of length zero is returned. If there is only one point (if \code{x} has length 1), then the nearest neighbour is undefined, and a value of \code{NA} is returned. In general if the number of points is less than or equal to \code{k}, then a vector of \code{NA}'s is returned. The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted R code only. If \code{method="C"} (the default) then C code is used. The C code is faster by two to three orders of magnitude and uses much less memory. To evaluate the \emph{distance} between a point and its nearest neighbour, use \code{\link{nndist}}. To find the nearest neighbours from one point pattern to another point pattern, use \code{\link{nncross}}. } \section{Nearest neighbours of each type}{ If \code{X} is a multitype point pattern and \code{by=marks(X)}, then the algorithm will find, for each point of \code{X}, the nearest neighbour of each type. See the Examples. } \section{Warnings}{ A value of \code{NA} is returned if there is only one point in the point pattern. } \seealso{ \code{\link{nndist}}, \code{\link{nncross}} } \examples{ plot(cells) m <- nnwhich(cells) m2 <- nnwhich(cells, k=2) # plot nearest neighbour links b <- cells[m] arrows(cells$x, cells$y, b$x, b$y, angle=15, length=0.15, col="red") # find points which are the neighbour of their neighbour self <- (m[m] == seq(m)) # plot them A <- cells[self] B <- cells[m[self]] plot(cells) segments(A$x, A$y, B$x, B$y) # nearest neighbours of each type head(nnwhich(ants, by=marks(ants))) } \author{ \pavel and \adrian } \keyword{spatial} \keyword{math} spatstat.geom/man/integral.tessfun.Rd0000644000176200001440000000276314765164643017430 0ustar liggesusers\name{integral.tessfun} \alias{integral.tessfun} \title{ Integrate a Function Which is Constant on Each Tile of a Tessellation } \description{ Given a function which is constant on each tile of a tessellation, compute the integral of the function. } \usage{ \method{integral}{tessfun}(f, domain = NULL, \dots) } \arguments{ \item{f}{ Integrand. A function of class \code{"tessfun"} (created by \code{\link[spatstat.geom]{as.function.tess}}). } \item{domain}{ Optional window (object of class \code{"owin"}) specifying a subregion to which the integral should be restricted. } \item{\dots}{ Ignored. } } \details{ The command \code{\link[spatstat.univar]{integral}} is generic. This is the method for objects of class \code{"tessfun"}. The integrand \code{f} should be a function of class \code{"tessfun"} created by \code{\link[spatstat.geom]{as.function.tess}}. It represents a function which takes a constant value on each tile of a tessellation. The integral is calculated by multiplying the area of each tile by the value of the function in that tile, and summing. This avoids the need for discretisation and avoids concomitant discretisation errors. } \value{ A single numeric value. } \author{ \adrian. } \seealso{ \code{\link[spatstat.geom]{as.function.tess}}. } \examples{ V <- dirichlet(runifrect(5)) f <- as.function(V, values=1/tile.areas(V)) integral(f) # should be close to 5. } \keyword{spatial} \keyword{math} \concept{Tessellation} spatstat.geom/man/boundingcircle.Rd0000644000176200001440000000423614643111575017110 0ustar liggesusers\name{boundingcircle} \alias{boundingradius} \alias{boundingradius.owin} \alias{boundingradius.ppp} \alias{boundingcentre} \alias{boundingcircle} \alias{boundingcentre.owin} \alias{boundingcircle.owin} \alias{boundingcentre.ppp} \alias{boundingcircle.ppp} \title{ Smallest Enclosing Circle } \description{ Find the smallest circle enclosing a spatial window or other object. Return its radius, or the location of its centre, or the circle itself. } \usage{ boundingradius(x, \dots) boundingcentre(x, \dots) boundingcircle(x, \dots) \method{boundingradius}{owin}(x, \dots) \method{boundingcentre}{owin}(x, \dots) \method{boundingcircle}{owin}(x, \dots) \method{boundingradius}{ppp}(x, \dots) \method{boundingcentre}{ppp}(x, \dots) \method{boundingcircle}{ppp}(x, \dots) } \arguments{ \item{x}{ A window (object of class \code{"owin"}), or another spatial object. } \item{\dots}{ Arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution for the calculation. } } \details{ The \code{boundingcircle} of a spatial region \eqn{W} is the smallest circle that contains \eqn{W}. The \code{boundingradius} is the radius of this circle, and the \code{boundingcentre} is the centre of the circle. The functions \code{boundingcircle}, \code{boundingcentre} and \code{boundingradius} are generic. There are methods for objects of class \code{"owin"}, \code{"ppp"} and \code{"linnet"}. } \value{ The result of \code{boundingradius} is a single numeric value. The result of \code{boundingcentre} is a point pattern containing a single point. The result of \code{boundingcircle} is a window representing the boundingcircle. } \author{ \adrian } \seealso{ \code{\link{diameter}} } \examples{ boundingradius(letterR) plot(grow.rectangle(Frame(letterR), 0.2), main="", type="n") plot(letterR, add=TRUE, col="grey") plot(boundingcircle(letterR), add=TRUE, border="green", lwd=2) plot(boundingcentre(letterR), pch="+", cex=2, col="blue", add=TRUE) X <- runifrect(5) plot(X) plot(boundingcircle(X), add=TRUE) plot(boundingcentre(X), pch="+", cex=2, col="blue", add=TRUE) } \keyword{spatial} \keyword{math} spatstat.geom/man/pHcolourmap.Rd0000644000176200001440000000545314611065347016414 0ustar liggesusers\name{pHcolourmap} \alias{pHcolourmap} \alias{pHcolour} \title{ Colour Map for pH Values } \description{ Create a colour map for values of \eqn{pH}. } \usage{ pHcolourmap(range = c(0, 14), ..., n=256, step = FALSE) pHcolour(pH) } \arguments{ \item{n}{ Number of different colour values to be used, when \code{step=FALSE}. } \item{range}{ Range of \eqn{pH} values that will be accepted as inputs to the colour map. A numeric vector of length 2 giving the minimum and maximum values of \eqn{pH}. } \item{step}{ Logical value. If \code{step=FALSE} (the default) the colours change continuously with increasing values of the input. If \code{step=TRUE}, the colour is constant on each unit interval of \eqn{pH} values. } \item{\dots}{Ignored.} \item{pH}{ Numerical value or numeric vector of values of \eqn{pH}. } } \details{ In chemistry the hydrogen potential \eqn{pH} measures how acidic or basic a solution is. The function \code{pHcolour} calculates the colour associated with a given value of \eqn{pH}, according to a standard mapping in which neutral \eqn{pH=7} is green, acidic values \eqn{pH < 7} are yellow or red, and basic values \eqn{pH > 7} are blue. The function \code{pHcolour} takes a numerical value or vector of values of \eqn{pH} and returns a character vector containing the corresponding colours. The function \code{pHcolourmap} produces a colour map for numerical values of \eqn{pH}, using the same consistent mapping of \eqn{pH} values to colours. The argument \code{range} specifies the range of \eqn{pH} values that will be mapped by the resulting colour map. It should be a numeric vector of length 2 giving the minimum and maximum values of \eqn{pH} that the colour map will handle. (Colour maps created with different values of \code{range} use essentially the same mapping of colours, but when plotted as colour ribbons, display only the specified range.) If \code{step=FALSE} (the default) the colours change continuously with increasing values of the input. There will be \code{n} different colour values in the colour map. Usually \code{n} should be a large number. If \code{step=TRUE}, the colour is constant on each unit interval of \eqn{pH} values. That is, any value of \eqn{pH} in the interval \eqn{[k, k+1]}, where \eqn{k} is an integer, will be mapped to the same colour. } \value{ The return value of \code{pHcolour} is a character string or a vector of character strings representing colours. The return value of \code{pHcolourmap} is a colour map (object of class \code{"colourmap"}). } \author{ \adrian. } \seealso{ \code{\link{colourmap}} } \examples{ pHcolour(7) plot(pHcolourmap()) plot(pHcolourmap(step=TRUE)) plot(pHcolourmap(c(3, 8))) } \keyword{spatial} \keyword{color} spatstat.geom/man/simplify.owin.Rd0000644000176200001440000000256614611065350016726 0ustar liggesusers\name{simplify.owin} \Rdversion{1.1} \alias{simplify.owin} \title{ Approximate a Polygon by a Simpler Polygon } \description{ Given a polygonal window, this function finds a simpler polygon that approximates it. } \usage{ simplify.owin(W, dmin) } \arguments{ \item{W}{ The polygon which is to be simplied. An object of class \code{"owin"}. } \item{dmin}{ Numeric value. The smallest permissible length of an edge. } } \details{ This function simplifies a polygon \code{W} by recursively deleting the shortest edge of \code{W} until all remaining edges are longer than the specified minimum length \code{dmin}, or until there are only three edges left. The argument \code{W} must be a window (object of class \code{"owin"}). It should be of type \code{"polygonal"}. If \code{W} is a rectangle, it is returned without alteration. The simplification algorithm is not yet implemented for binary masks. If \code{W} is a mask, an error is generated. } \value{ Another window (object of class \code{"owin"}) of type \code{"polygonal"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{owin}} } \examples{ plot(letterR, col="red") plot(simplify.owin(letterR, 0.3), col="blue", add=TRUE) W <- Window(chorley) plot(W) WS <- simplify.owin(W, 2) plot(WS, add=TRUE, border="green") points(vertices(WS)) } \keyword{spatial} \keyword{math} spatstat.geom/man/rotate.psp.Rd0000644000176200001440000000272014611065350016206 0ustar liggesusers\name{rotate.psp} \alias{rotate.psp} \title{Rotate a Line Segment Pattern} \description{ Rotates a line segment pattern } \usage{ \method{rotate}{psp}(X, angle=pi/2, \dots, centre=NULL) } \arguments{ \item{X}{A line segment pattern (object of class \code{"psp"}).} \item{angle}{Angle of rotation.} \item{\dots}{ Arguments passed to \code{\link{rotate.owin}} affecting the handling of the observation window, if it is a binary pixel mask. } \item{centre}{ Centre of rotation. Either a vector of length 2, or a character string (partially matched to \code{"centroid"}, \code{"midpoint"} or \code{"bottomleft"}). The default is the coordinate origin \code{c(0,0)}. } } \value{ Another object of class \code{"psp"} representing the rotated line segment pattern. } \details{ The line segments of the pattern, and the window of observation, are rotated about the origin by the angle specified. Angles are measured in radians, anticlockwise. The default is to rotate the pattern 90 degrees anticlockwise. If the line segments carry marks, these are preserved. } \seealso{ \code{\link{psp.object}}, \code{\link{rotate.owin}}, \code{\link{rotate.ppp}} } \examples{ oldpar <- par(mfrow=c(2,1)) X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) plot(X, main="original") Y <- rotate(X, pi/4) plot(Y, main="rotated") par(oldpar) } \author{\adrian and \rolf } \keyword{spatial} \keyword{math} spatstat.geom/man/marks.tess.Rd0000644000176200001440000000426014676150557016221 0ustar liggesusers\name{marks.tess} \alias{marks.tess} \alias{marks<-.tess} \alias{unmark.tess} \title{Marks of a Tessellation} \description{ Extract or change the marks attached to the tiles of a tessellation. } \usage{ \method{marks}{tess}(x, \dots) \method{marks}{tess}(x, \dots) <- value \method{unmark}{tess}(X) } \arguments{ \item{x,X}{ Tessellation (object of class \code{"tess"}) } \item{\dots}{ Ignored. } \item{value}{ Vector or data frame of mark values, or \code{NULL}. } } \value{ For \code{marks(x)}, the result is a vector, factor, data frame or hyperframe, containing the mark values attached to the tiles of \code{x}. If there are no marks, the result is \code{NULL}. For \code{unmark(x)}, the result is the tessellation without marks. For \code{marks(x) <- value}, the result is the updated tessellation \code{x} (with the side-effect that the dataset \code{x} is updated in the current environment). } \details{ These functions extract or change the marks attached to each of the tiles in the tessellation \code{x}. They are methods for the generic functions \code{\link{marks}}, \code{\link{marks<-}} and \code{\link{unmark}} for the class \code{"tess"} of tessellations The expression \code{marks(x)} extracts the marks of \code{x}. The assignment \code{marks(x) <- value} assigns new marks to the dataset \code{x}, and updates the dataset \code{x} in the current environment. The marks can be a vector, a factor, a data frame or a hyperframe. For the assignment \code{marks(x) <- value}, the \code{value} should be a vector or factor of length equal to the number of tiles in \code{x}, or a data frame or hyperframe with as many rows as there are tiles in \code{x}. If \code{value} is a single value, or a data frame or hyperframe with one row, then it will be replicated so that the same marks will be attached to each tile. To remove marks, use \code{marks(x) <- NULL} or \code{unmark(x)}. } \seealso{ \code{\link{marks}}, \code{\link{marks<-}} } \examples{ D <- dirichlet(cells) marks(D) <- tile.areas(D) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} \concept{Tessellation} spatstat.geom/man/nndist.Rd0000644000176200001440000002000214742317357015413 0ustar liggesusers\name{nndist} \alias{nndist} \alias{nndist.ppp} \alias{nndist.default} \title{Nearest neighbour distances} \description{ Computes the distance from each point to its nearest neighbour in a point pattern. Alternatively computes the distance to the second nearest neighbour, or third nearest, etc. } \usage{ nndist(X, \dots) \method{nndist}{ppp}(X, \dots, k=1, by=NULL, method="C", metric=NULL) \method{nndist}{default}(X, Y=NULL, \dots, k=1, by=NULL, method="C") } \arguments{ \item{X,Y}{ Arguments specifying the locations of a set of points. For \code{nndist.ppp}, the argument \code{X} should be a point pattern (object of class \code{"ppp"}). For \code{nndist.default}, typically \code{X} and \code{Y} would be numeric vectors of equal length. Alternatively \code{Y} may be omitted and \code{X} may be a list with two components \code{x} and \code{y}, or a matrix with two columns. Alternatively \code{X} can be a three-dimensional point pattern (class \code{"pp3"}), a higher-dimensional point pattern (class \code{"ppx"}), a point pattern on a linear network (class \code{"lpp"}), or a spatial pattern of line segments (class \code{"psp"}). } \item{\dots}{ Ignored by \code{nndist.ppp} and \code{nndist.default}. } \item{k}{ Integer, or integer vector. The algorithm will compute the distance to the \code{k}th nearest neighbour. } \item{by}{ Optional. A factor, which separates \code{X} into groups. The algorithm will compute the distance to the nearest point in each group. See Details. } \item{method}{String specifying which method of calculation to use. Values are \code{"C"} and \code{"interpreted"}. } \item{metric}{ Optional. A metric (object of class \code{"metric"}) that will be used to define and compute the distances. } } \value{ Numeric vector or matrix containing the nearest neighbour distances for each point. If \code{k = 1} (the default), the return value is a numeric vector \code{v} such that \code{v[i]} is the nearest neighbour distance for the \code{i}th data point. If \code{k} is a single integer, then the return value is a numeric vector \code{v} such that \code{v[i]} is the \code{k}th nearest neighbour distance for the \code{i}th data point. If \code{k} is a vector, then the return value is a matrix \code{m} such that \code{m[i,j]} is the \code{k[j]}th nearest neighbour distance for the \code{i}th data point. If the argument \code{by} is given, then it should be a \code{factor} which separates \code{X} into groups (or any type of data acceptable to \code{\link{split.ppp}} that determines the grouping). The result is a data frame containing the distances described above, from each point of \code{X}, to the nearest point in each subset of \code{X} defined by the grouping factor \code{by}. } \details{ This function computes the Euclidean distance from each point in a point pattern to its nearest neighbour (the nearest other point of the pattern). If \code{k} is specified, it computes the distance to the \code{k}th nearest neighbour. The function \code{nndist} is generic, with a method for point patterns (objects of class \code{"ppp"}), and a default method for coordinate vectors. There are also methods for line segment patterns, \code{\link{nndist.psp}}, three-dimensional point patterns, \code{\link{nndist.pp3}}, higher-dimensional point patterns, \code{\link{nndist.ppx}} and point patterns on a linear network, \code{nndist.lpp}; these are described in their own help files. Type \code{methods(nndist)} to see all available methods. The method for planar point patterns \code{nndist.ppp} expects a single point pattern argument \code{X} and returns the vector of its nearest neighbour distances. The default method expects that \code{X} and \code{Y} will determine the coordinates of a set of points. Typically \code{X} and \code{Y} would be numeric vectors of equal length. Alternatively \code{Y} may be omitted and \code{X} may be a list with two components named \code{x} and \code{y}, or a matrix or data frame with two columns. The argument \code{k} may be a single integer, or an integer vector. If it is a vector, then the \eqn{k}th nearest neighbour distances are computed for each value of \eqn{k} specified in the vector. If the argument \code{by} is given, it should be a \code{factor}, of length equal to the number of points in \code{X}. This factor effectively partitions \code{X} into subsets, each subset associated with one of the levels of \code{X}. The algorithm will then compute, for each point of \code{X}, the distance to the nearest neighbour \emph{in each subset}. The argument \code{method} is not normally used. It is retained only for checking the validity of the software. If \code{method = "interpreted"} then the distances are computed using interpreted R code only. If \code{method="C"} (the default) then C code is used. The C code is faster by two to three orders of magnitude and uses much less memory. If there is only one point (if \code{x} has length 1), then a nearest neighbour distance of \code{Inf} is returned. If there are no points (if \code{x} has length zero) a numeric vector of length zero is returned. To identify \emph{which} point is the nearest neighbour of a given point, use \code{\link{nnwhich}}. To use the nearest neighbour distances for statistical inference, it is often advisable to use the edge-corrected empirical distribution, computed by \code{\link[spatstat.explore]{Gest}}. To find the nearest neighbour distances from one point pattern to another point pattern, use \code{\link{nncross}}. } \section{Nearest neighbours of each type}{ If \code{X} is a multitype point pattern and \code{by=marks(X)}, then the algorithm will compute, for each point of \code{X}, the distance to the nearest neighbour of each type. See the Examples. To find the minimum distance from \emph{any} point of type \code{i} to the nearest point of type \code{j}, for all combinations of \code{i} and \code{j}, use \code{\link{minnndist}}, or the \R function \code{\link[stats]{aggregate}} as suggested in the Examples. } \section{Warnings}{ An infinite or \code{NA} value is returned if the distance is not defined (e.g. if there is only one point in the point pattern). } \section{Distance values}{ The values returned by \code{nndist(X)} are distances, expressed as multiples of the unit of length of the spatial coordinates in \code{X}. The unit of length is given by \code{\link{unitname}(X)}. Note that, if the unit of length in \code{X} is a composite expression such as \sQuote{2 microns}, then the values of \code{nndist(X)} are expressed as multiples of 2 microns, rather than being expressed in microns. } \seealso{ \code{\link{nndist.psp}}, \code{\link{nndist.pp3}}, \code{\link{nndist.ppx}}, \code{\link{pairdist}}, \code{\link[spatstat.explore]{Gest}}, \code{\link{nnwhich}}, \code{\link{nncross}}, \code{\link{minnndist}}, \code{\link{maxnndist}}. } \examples{ # nearest neighbours d <- nndist(cells) # second nearest neighbours d2 <- nndist(cells, k=2) # first, second and third nearest d1to3 <- nndist(cells, k=1:3) x <- runif(100) y <- runif(100) d <- nndist(x, y) # Stienen diagram plot(cells \%mark\% nndist(cells), markscale=1) # distance to nearest neighbour of each type nnda <- nndist(ants, by=marks(ants)) head(nnda) # For nest number 1, the nearest Cataglyphis nest is 87.32125 units away # minimum distance between each pair of types minnndist(ants, by=marks(ants)) # Use of 'aggregate': # _minimum_ distance between each pair of types aggregate(nnda, by=list(from=marks(ants)), min) # _mean_ nearest neighbour distances aggregate(nnda, by=list(from=marks(ants)), mean) # The mean distance from a Messor nest to # the nearest Cataglyphis nest is 59.02549 units } \author{ \pavel and \adrian. } \keyword{spatial} \keyword{math} spatstat.geom/man/stratrand.Rd0000644000176200001440000000376614611065350016124 0ustar liggesusers\name{stratrand} \alias{stratrand} \title{Stratified random point pattern} \description{ Generates a \dQuote{stratified random} pattern of points in a window, by dividing the window into rectangular tiles and placing \code{k} random points in each tile. } \usage{ stratrand(window, nx, ny, k = 1) } \arguments{ \item{window}{A window. An object of class \code{\link{owin}}, or data in any format acceptable to \code{\link{as.owin}()}. } \item{nx}{Number of tiles in each row. } \item{ny}{Number of tiles in each column. } \item{k}{Number of random points to generate in each tile. } } \value{ A list with two components \code{x} and \code{y}, which are numeric vectors giving the coordinates of the random points. } \details{ The bounding rectangle of \code{window} is divided into a regular \eqn{nx \times ny}{nx * ny} grid of rectangular tiles. In each tile, \code{k} random points are generated independently with a uniform distribution in that tile. Note that some of these grid points may lie outside the window, if \code{window} is not of type \code{"rectangle"}. The function \code{\link{inside.owin}} can be used to select those grid points which do lie inside the window. See the examples. This function is useful in creating dummy points for quadrature schemes (see \code{\link{quadscheme}}) as well as in simulating random point patterns. } \seealso{ \code{\link{quad.object}}, \code{\link{quadscheme}}, \code{\link{inside.owin}}, \code{\link{gridcentres}} } \examples{ w <- unit.square() xy <- stratrand(w, 10, 10) # plot(w) # points(xy) # polygonal boundary bdry <- list(x=c(0.1,0.3,0.7,0.4,0.2), y=c(0.1,0.1,0.5,0.7,0.3)) w <- owin(c(0,1), c(0,1), poly=bdry) xy <- stratrand(w, 10, 10, 3) # plot(w) # points(xy) # determine which grid points are inside polygon ok <- inside.owin(xy$x, xy$y, w) # plot(w) # points(xy$x[ok], xy$y[ok]) } \author{\adrian and \rolf } \keyword{spatial} \keyword{datagen} spatstat.geom/man/nvertices.Rd0000644000176200001440000000160114611065347016114 0ustar liggesusers\name{nvertices} \alias{nvertices} \alias{nvertices.owin} \alias{nvertices.default} \title{ Count Number of Vertices } \description{ Count the number of vertices in an object for which vertices are well-defined. } \usage{ nvertices(x, \dots) \method{nvertices}{owin}(x, \dots) \method{nvertices}{default}(x, \dots) } \arguments{ \item{x}{ A window (object of class \code{"owin"}), or some other object which has vertices. } \item{\dots}{ Currently ignored. } } \details{ This function counts the number of vertices of \code{x} as they would be returned by \code{\link{vertices}(x)}. It is more efficient than executing \code{npoints(vertices(x))}. } \value{ A single integer. } \author{ \spatstatAuthors and Suman Rakshit. } \seealso{ \code{\link{vertices}} } \examples{ nvertices(square(2)) nvertices(letterR) } \keyword{spatial} \keyword{manip} spatstat.geom/man/invoke.symbolmap.Rd0000644000176200001440000000427214611065346017415 0ustar liggesusers\name{invoke.symbolmap} \alias{invoke.symbolmap} \title{ Plot Data Using Graphics Symbol Map } \description{ Apply a graphics symbol map to a vector of data values and plot the resulting symbols. } \usage{ invoke.symbolmap(map, values, x=NULL, y = NULL, \dots, angleref=NULL, add = FALSE, do.plot = TRUE, started = add && do.plot) } \arguments{ \item{map}{ Graphics symbol map (object of class \code{"symbolmap"}). } \item{values}{ Vector of data that can be mapped by the symbol map. } \item{x,y}{ Coordinate vectors for the spatial locations of the symbols to be plotted. } \item{\dots}{ Additional graphics parameters (which will be applied to the entire plot). } \item{angleref}{ Optional. Reference angle, or vector of reference angles, used when plotting some of the symbols. A numeric value or vector giving angles in degrees between 0 and 360. } \item{add}{ Logical value indicating whether to add the symbols to an existing plot (\code{add=TRUE}) or to initialise a new plot (\code{add=FALSE}, the default). } \item{do.plot}{ Logical value indicating whether to actually perform the plotting. } \item{started}{ Logical value indicating whether the plot has already been initialised. } } \details{ A symbol map is an association between data values and graphical symbols. This command applies the symbol map \code{map} to the data \code{values} and plots the resulting symbols at the locations given by \code{\link{xy.coords}(x,y)}. } \value{ (Invisibly) the maximum diameter of the symbols, in user coordinate units. } \author{ \spatstatAuthors. } \seealso{ \code{\link{plot.symbolmap}} to plot the graphics map itself. \code{\link{symbolmap}} to create a graphics map. } \examples{ g <- symbolmap(range=c(-1,1), shape=function(x) ifelse(x > 0, "circles", "squares"), size=function(x) sqrt(ifelse(x > 0, x/pi, -x))/15, bg=function(x) ifelse(x > 0, "green", "red")) plot(square(1), main="") a <- invoke.symbolmap(g, runif(10, -1, 1), runifrect(10), add=TRUE) a } \keyword{spatial} \keyword{hplot} spatstat.geom/man/dilation.Rd0000644000176200001440000000554114643111575015724 0ustar liggesusers\name{dilation} \alias{dilation} \alias{dilation.owin} \alias{dilation.ppp} \alias{dilation.psp} \title{Morphological Dilation} \description{ Perform morphological dilation of a window, a line segment pattern or a point pattern } \usage{ dilation(w, r, \dots) \method{dilation}{owin}(w, r, \dots, polygonal=NULL, tight=TRUE) \method{dilation}{ppp}(w, r, \dots, polygonal=TRUE, tight=TRUE) \method{dilation}{psp}(w, r, \dots, polygonal=TRUE, tight=TRUE) } \arguments{ \item{w}{ A window (object of class \code{"owin"} or a line segment pattern (object of class \code{"psp"}) or a point pattern (object of class \code{"ppp"}). } \item{r}{positive number: the radius of dilation.} \item{\dots}{extra arguments passed to \code{\link[spatstat.geom]{as.mask}} controlling the pixel resolution, if the pixel approximation is used; or passed to \code{\link{disc}} if the polygonal approximation is used. } \item{polygonal}{ Logical flag indicating whether to compute a polygonal approximation to the dilation (\code{polygonal=TRUE}) or a pixel grid approximation (\code{polygonal=FALSE}). } \item{tight}{ Logical flag indicating whether the bounding frame of the window should be taken as the smallest rectangle enclosing the dilated region (\code{tight=TRUE}), or should be the dilation of the bounding frame of \code{w} (\code{tight=FALSE}). } } \value{ If \code{r > 0}, an object of class \code{"owin"} representing the dilated region. If \code{r=0}, the result is identical to \code{w}. } \details{ The morphological dilation of a set \eqn{W} by a distance \eqn{r > 0} is the set consisting of all points lying at most \eqn{r} units away from \eqn{W}. Effectively, dilation adds a margin of width \eqn{r} onto the set \eqn{W}. If \code{polygonal=TRUE} then a polygonal approximation to the dilation is computed. If \code{polygonal=FALSE} then a pixel approximation to the dilation is computed from the distance map of \code{w}. The arguments \code{"\dots"} are passed to \code{\link[spatstat.geom]{as.mask}} to control the pixel resolution. When \code{w} is a window, the default (when \code{polygonal=NULL}) is to compute a polygonal approximation if \code{w} is a rectangle or polygonal window, and to compute a pixel approximation if \code{w} is a window of type \code{"mask"}. } \seealso{ \code{\link{erosion}} for the opposite operation. \code{\link{dilationAny}} for morphological dilation using any shape. \code{\link{owin}}, \code{\link{as.owin}} } \examples{ plot(dilation(redwood, 0.05)) points(redwood) plot(dilation(letterR, 0.2)) plot(letterR, add=TRUE, lwd=2, border="red") X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) plot(dilation(X, 0.1)) plot(X, add=TRUE, col="red") } \author{ \spatstatAuthors } \keyword{spatial} \keyword{math} spatstat.geom/man/psp2mask.Rd0000644000176200001440000000343214643111575015656 0ustar liggesusers\name{psp2mask} \alias{psp2mask} \alias{as.mask.psp} \title{ Convert Line Segment Pattern to Binary Pixel Mask } \description{ Converts a line segment pattern to a binary pixel mask by determining which pixels intersect the lines. } \usage{ psp2mask(x, W=NULL, ...) as.mask.psp(x, W=NULL, ...) } \arguments{ \item{x}{ Line segment pattern (object of class \code{"psp"}). } \item{W}{ Optional window (object of class \code{"owin"}) determining the pixel raster. } \item{\dots}{ Optional extra arguments passed to \code{\link[spatstat.geom]{as.mask}} to determine the pixel resolution. } } \details{ The functions \code{psp2mask} and \code{as.mask.psp} are currently identical. In future versions of the package, \code{as.mask.psp} will be deprecated, and then removed. This function converts a line segment pattern to a binary pixel mask by determining which pixels intersect the lines. The pixel raster is determined by \code{W} and the optional arguments \code{\dots}. If \code{W} is missing or \code{NULL}, it defaults to the window containing \code{x}. Then \code{W} is converted to a binary pixel mask using \code{\link[spatstat.geom]{as.mask}}. The arguments \code{\dots} are passed to \code{\link[spatstat.geom]{as.mask}} to control the pixel resolution. } \value{ A window (object of class \code{"owin"}) which is a binary pixel mask (type \code{"mask"}). } \seealso{ \code{\link{pixellate.psp}}, \code{\link[spatstat.geom]{as.mask}}. Use \code{\link{pixellate.psp}} if you want to measure the length of line in each pixel. } \examples{ X <- psp(runif(10), runif(10), runif(10), runif(10), window=owin()) plot(psp2mask(X)) plot(X, add=TRUE, col="red") } \author{ \adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/periodify.Rd0000644000176200001440000000727214611065347016116 0ustar liggesusers\name{periodify} \alias{periodify} \alias{periodify.owin} \alias{periodify.ppp} \alias{periodify.psp} \title{ Make Periodic Copies of a Spatial Pattern } \description{ Given a spatial pattern (point pattern, line segment pattern, window, etc) make shifted copies of the pattern and optionally combine them to make a periodic pattern. } \usage{ periodify(X, ...) \method{periodify}{ppp}(X, nx = 1, ny = 1, ..., combine=TRUE, warn=TRUE, check=TRUE, ix=(-nx):nx, iy=(-ny):ny, ixy=expand.grid(ix=ix,iy=iy)) \method{periodify}{psp}(X, nx = 1, ny = 1, ..., combine=TRUE, warn=TRUE, check=TRUE, ix=(-nx):nx, iy=(-ny):ny, ixy=expand.grid(ix=ix,iy=iy)) \method{periodify}{owin}(X, nx = 1, ny = 1, ..., combine=TRUE, warn=TRUE, ix=(-nx):nx, iy=(-ny):ny, ixy=expand.grid(ix=ix,iy=iy)) } \arguments{ \item{X}{ An object representing a spatial pattern (point pattern, line segment pattern or window). } \item{nx,ny}{ Integers. Numbers of additional copies of \code{X} in each direction. The result will be a grid of \code{2 * nx + 1} by \code{2 * ny + 1} copies of the original object. (Overruled by \code{ix, iy, ixy}). } \item{\dots}{ Ignored. } \item{combine}{ Logical flag determining whether the copies should be superimposed to make an object like \code{X} (if \code{combine=TRUE}) or simply returned as a list of objects (\code{combine=FALSE}). } \item{warn}{ Logical flag determining whether to issue warnings. } \item{check}{ Logical flag determining whether to check the validity of the combined pattern. } \item{ix, iy}{ Integer vectors determining the grid positions of the copies of \code{X}. (Overruled by \code{ixy}). } \item{ixy}{ Matrix or data frame with two columns, giving the grid positions of the copies of \code{X}. } } \details{ Given a spatial pattern (point pattern, line segment pattern, etc) this function makes a number of shifted copies of the pattern and optionally combines them. The function \code{periodify} is generic, with methods for various kinds of spatial objects. The default is to make a 3 by 3 array of copies of \code{X} and combine them into a single pattern of the same kind as \code{X}. This can be used (for example) to compute toroidal or periodic edge corrections for various operations on \code{X}. If the arguments \code{nx}, \code{ny} are given and other arguments are missing, the original object will be copied \code{nx} times to the right and \code{nx} times to the left, then \code{ny} times upward and \code{ny} times downward, making \code{(2 * nx + 1) * (2 * ny + 1)} copies altogether, arranged in a grid, centred on the original object. If the arguments \code{ix}, \code{iy} or \code{ixy} are specified, then these determine the grid positions of the copies of \code{X} that will be made. For example \code{(ix,iy) = (1, 2)} means a copy of \code{X} shifted by the vector \code{(ix * w, iy * h)} where \code{w,h} are the width and height of the bounding rectangle of \code{X}. If \code{combine=TRUE} (the default) the copies of \code{X} are superimposed to create an object of the same kind as \code{X}. If \code{combine=FALSE} the copies of \code{X} are returned as a list. } \value{ If \code{combine=TRUE}, an object of the same class as \code{X}. If \code{combine=FALSE}, a list of objects of the same class as \code{X}. } \seealso{ \code{\link{shift}} } \examples{ plot(periodify(cells)) a <- lapply(periodify(Window(cells), combine=FALSE), plot, add=TRUE,lty=2) } \author{\adrian and \rolf } \keyword{spatial} \keyword{manip} spatstat.geom/man/lut.Rd0000644000176200001440000000767314611065347014735 0ustar liggesusers\name{lut} \alias{lut} \title{Lookup Tables} \description{ Create a lookup table. } \usage{ lut(outputs, ..., range=NULL, breaks=NULL, inputs=NULL, gamma=1) } \arguments{ \item{outputs}{Vector of output values} \item{\dots}{Ignored.} \item{range}{ Interval of numbers to be mapped. A numeric vector of length 2, specifying the ends of the range of values to be mapped. Incompatible with \code{breaks} or \code{inputs}. } \item{inputs}{ Input values to which the output values are associated. A factor or vector of the same length as \code{outputs}. Incompatible with \code{breaks} or \code{range}. } \item{breaks}{ Breakpoints for the lookup table. A numeric vector of length equal to \code{length(outputs)+1}. Incompatible with \code{range} or \code{inputs}. } \item{gamma}{ Exponent for gamma correction, when \code{range} is given. A single positive number. See Details. } } \details{ A lookup table is a function, mapping input values to output values. The command \code{lut} creates an object representing a lookup table, which can then be used to control various behaviour in the \pkg{spatstat} package. It can also be used to compute the output value assigned to any input value. The argument \code{outputs} specifies the output values to which input data values will be mapped. It should be a vector of any atomic type (e.g. numeric, logical, character, complex) or factor values. Exactly one of the arguments \code{range}, \code{inputs} or \code{breaks} must be specified by name. \itemize{ \item If \code{inputs} is given, then it should be a vector or factor, of the same length as \code{outputs}. The entries of \code{inputs} can be any atomic type (e.g. numeric, logical, character, complex) or factor values. The resulting lookup table associates the value \code{inputs[i]} with the value \code{outputs[i]}. The argument \code{outputs} should have the same length as \code{inputs}. \item If \code{range} is given, then it determines the interval of the real number line that will be mapped. It should be a numeric vector of length 2. The interval will be divided evenly into bands, each of which is mapped to an entry of \code{outputs}. (If \code{gamma} is given, then the bands are equally spaced on a scale where the original values are raised to the power \code{gamma}.) \item If \code{breaks} is given, then it determines intervals of the real number line which are mapped to each output value. It should be a numeric vector, of length at least 2, with entries that are in increasing order. Infinite values are allowed. Any number in the range between \code{breaks[i]} and \code{breaks[i+1]} will be mapped to the value \code{outputs[i]}. The argument \code{outputs} should have length equal to \code{length(breaks) - 1}. } It is also permissible for \code{outputs} to be a single value, representing a trivial lookup table in which all data values are mapped to the same output value. The result is an object of class \code{"lut"}. There is a \code{print} method for this class. Some plot commands in the \pkg{spatstat} package accept an object of this class as a specification of a lookup table. The result is also a function \code{f} which can be used to compute the output value assigned to any input data value. That is, \code{f(x)} returns the output value assigned to \code{x}. This also works for vectors of input data values. } \value{ A function, which is also an object of class \code{"lut"}. } \seealso{ \code{\link{colourmap}}. } \examples{ # lookup table for real numbers, using breakpoints cr <- lut(factor(c("low", "medium", "high")), breaks=c(0,5,10,15)) cr cr(3.2) cr(c(3,5,7)) # lookup table for discrete set of values ct <- lut(c(0,1), inputs=c(FALSE, TRUE)) ct(TRUE) } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{manip} spatstat.geom/man/solapply.Rd0000644000176200001440000000323014611065350015747 0ustar liggesusers\name{solapply} \alias{solapply} \alias{anylapply} \title{ Apply a Function Over a List and Obtain a List of Objects } \description{ Applies the function \code{FUN} to each element of the list \code{X}, and returns the result as a list of class \code{"solist"} or \code{"anylist"} as appropriate. } \usage{ anylapply(X, FUN, \dots) solapply(X, FUN, \dots, check = TRUE, promote = TRUE, demote = FALSE) } \arguments{ \item{X}{A list.} \item{FUN}{ Function to be applied to each element of \code{X}. } \item{\dots}{ Additional arguments to \code{FUN}. } \item{check,promote,demote}{ Arguments passed to \code{\link{solist}} which determine how to handle different classes of objects. } } \details{ These convenience functions are similar to \code{\link[base]{lapply}} except that they return a list of class \code{"solist"} or \code{"anylist"}. In both functions, the result is computed by \code{lapply(X, FUN, \dots)}. In \code{anylapply} the result is converted to a list of class \code{"anylist"} and returned. In \code{solapply} the result is converted to a list of class \code{"solist"} \bold{if possible}, using \code{\link{as.solist}}. If this is not possible, then the behaviour depends on the argument \code{demote}. If \code{demote=TRUE} the result will be returned as a list of class \code{"anylist"}. If \code{demote=FALSE} (the default), an error occurs. } \value{ A list, usually of class \code{"solist"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{solist}}, \code{\link{anylist}}. } \examples{ solapply(waterstriders, distmap) } \keyword{spatial} \keyword{list} \keyword{manip} spatstat.geom/DESCRIPTION0000644000176200001440000000673314766261237014600 0ustar liggesusersPackage: spatstat.geom Version: 3.3-6 Date: 2025-03-18 Title: Geometrical Functionality of the 'spatstat' Family Authors@R: c(person("Adrian", "Baddeley", role = c("aut", "cre", "cph"), email = "Adrian.Baddeley@curtin.edu.au", comment = c(ORCID="0000-0001-9499-8382")), person("Rolf", "Turner", role = c("aut", "cph"), email="rolfturner@posteo.net", comment=c(ORCID="0000-0001-5521-5218")), person("Ege", "Rubak", role = c("aut", "cph"), email = "rubak@math.aau.dk", comment=c(ORCID="0000-0002-6675-533X")), person("Warick", "Brown" , role = "ctb"), person("Tilman", "Davies", role = "ctb"), person("Ute", "Hahn", role = "ctb"), person("Martin", "Hazelton", role = "ctb"), person("Abdollah", "Jalilian", role = "ctb"), person("Greg", "McSwiggan", role = c("ctb", "cph")), person("Sebastian", "Meyer", role = c("ctb", "cph")), person("Jens", "Oehlschlaegel", role = c("ctb", "cph")), person("Suman", "Rakshit", role = "ctb"), person("Dominic", "Schuhmacher", role = "ctb"), person("Rasmus", "Waagepetersen", role = "ctb")) Maintainer: Adrian Baddeley Depends: R (>= 3.5.0), spatstat.data (>= 3.1), spatstat.univar (>= 3.1), stats, graphics, grDevices, utils, methods Imports: spatstat.utils (>= 3.1-2), deldir (>= 1.0-2), polyclip (>= 1.10) Suggests: spatstat.random (>= 3.3), spatstat.explore (>= 3.3), spatstat.model (>= 3.3), spatstat.linnet (>= 3.2), spatial, fftwtools (>= 0.9-8), spatstat (>= 3.3) Description: Defines spatial data types and supports geometrical operations on them. Data types include point patterns, windows (domains), pixel images, line segment patterns, tessellations and hyperframes. Capabilities include creation and manipulation of data (using command line or graphical interaction), plotting, geometrical operations (rotation, shift, rescale, affine transformation), convex hull, discretisation and pixellation, Dirichlet tessellation, Delaunay triangulation, pairwise distances, nearest-neighbour distances, distance transform, morphological operations (erosion, dilation, closing, opening), quadrat counting, geometrical measurement, geometrical covariance, colour maps, calculus on spatial domains, Gaussian blur, level sets of images, transects of images, intersections between objects, minimum distance matching. (Excludes spatial data on a network, which are supported by the package 'spatstat.linnet'.) License: GPL (>= 2) URL: http://spatstat.org/ NeedsCompilation: yes ByteCompile: true BugReports: https://github.com/spatstat/spatstat.geom/issues Packaged: 2025-03-18 00:10:50 UTC; adrian Author: Adrian Baddeley [aut, cre, cph] (), Rolf Turner [aut, cph] (), Ege Rubak [aut, cph] (), Warick Brown [ctb], Tilman Davies [ctb], Ute Hahn [ctb], Martin Hazelton [ctb], Abdollah Jalilian [ctb], Greg McSwiggan [ctb, cph], Sebastian Meyer [ctb, cph], Jens Oehlschlaegel [ctb, cph], Suman Rakshit [ctb], Dominic Schuhmacher [ctb], Rasmus Waagepetersen [ctb] Repository: CRAN Date/Publication: 2025-03-18 12:10:07 UTC