diff --git a/DESCRIPTION b/DESCRIPTION index ab1fdea..b1449d1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: spatstat.linnet -Version: 3.1-5.002 -Date: 2024-05-01 +Version: 3.1-5.003 +Date: 2024-06-05 Title: Linear Networks Functionality of the 'spatstat' Family Authors@R: c(person("Adrian", "Baddeley", role = c("aut", "cre", "cph"), diff --git a/NEWS b/NEWS index 98b3df3..83f27f1 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ - CHANGES IN spatstat.linnet VERSION 3.1-5.002 + CHANGES IN spatstat.linnet VERSION 3.1-5.003 OVERVIEW @@ -14,6 +14,9 @@ PACKAGE DEPENDENCE SIGNIFICANT USER-VISIBLE CHANGES + o thinNetwork + X can be a pixel image on a linear network (object of class 'linim'). + o plot.linnet, plot.lpp These functions now recognise the argument 'adj.main'. diff --git a/R/linnetsurgery.R b/R/linnetsurgery.R index 0ac5bf8..3b2b11b 100644 --- a/R/linnetsurgery.R +++ b/R/linnetsurgery.R @@ -3,7 +3,7 @@ #' #' Surgery on linear networks and related objects #' -#' $Revision: 1.34 $ $Date: 2022/07/20 08:13:54 $ +#' $Revision: 1.35 $ $Date: 2024/06/05 08:57:15 $ #' insertVertices <- function(L, ...) { @@ -251,20 +251,22 @@ repairNetwork <- function(X) { return(Y) } -thinNetwork <- function(X, retainvertices, retainedges) { +thinNetwork <- function(X, retainvertices=NULL, retainedges=NULL) { ## thin a network by retaining only the specified edges and/or vertices - if(!inherits(X, c("linnet", "lpp"))) - stop("X should be a linnet or lpp object", call.=FALSE) - gotvert <- !missing(retainvertices) - gotedge <- !missing(retainedges) + if(!inherits(X, c("linnet", "lpp", "linim"))) + stop("X should be a linnet or lpp or linim object", call.=FALSE) + gotvert <- !is.null(retainvertices) + gotedge <- !is.null(retainedges) if(!gotedge && !gotvert) return(X) + #' .................. extract data ................... L <- as.linnet(X) from <- L$from to <- L$to V <- L$vertices sparse <- identical(L$sparse, TRUE) edgemarks <- marks(L$lines) # vertex marks are handled automatically + #' .................................................. #' determine which edges/vertices are to be retained edgesFALSE <- logical(nsegments(L)) verticesFALSE <- logical(npoints(V)) @@ -290,6 +292,7 @@ thinNetwork <- function(X, retainvertices, retainedges) { retainvertices[from[retainedges]] <- TRUE retainvertices[to[retainedges]] <- TRUE } + #' ................ make sub-network ................. ## assign new serial numbers to vertices, and recode Vsub <- V[retainvertices] newserial <- cumsum(retainvertices) @@ -302,7 +305,7 @@ thinNetwork <- function(X, retainvertices, retainedges) { nontrivial <- (newfrom != newto) & !duplicated(edgepairs) edgepairs <- edgepairs[nontrivial,,drop=FALSE] reverse <- reverse[nontrivial] - ## extract relevant subset of network + ## construct relevant subset of network Lsub <- linnet(Vsub, edges=edgepairs, sparse=sparse, warn=FALSE) ## reattach marks to edges if(!is.null(edgemarks)) @@ -310,28 +313,51 @@ thinNetwork <- function(X, retainvertices, retainedges) { ## tack on information about subset attr(Lsub, "retainvertices") <- retainvertices attr(Lsub, "retainedges") <- retainedges - ## done? - if(inherits(X, "linnet")) + #' ............... handle data on the network ............. + if(inherits(X, "linnet")) { return(Lsub) - ## X is an lpp object - ## Find data points that lie on accepted segments - dat <- X$data # hyperframe, may include marks - ok <- retainedges[unlist(dat$seg)] - dsub <- dat[ok, , drop=FALSE] - ## compute new serial numbers for retained segments - segmap <- cumsum(retainedges) - oldseg <- as.integer(unlist(dsub$seg)) - dsub$seg <- newseg <- segmap[oldseg] - ## adjust tp coordinate if segment endpoints were reversed - if(any(revseg <- reverse[newseg])) { - tp <- as.numeric(unlist(dsub$tp)) - dsub$tp[revseg] <- 1 - tp[revseg] + } else if(inherits(X, "linim")) { + #' extract pixel data + Xim <- as.im(X) + XimLsub <- Xim[Lsub, drop=FALSE] + #' extract data frame of sample points and image values on subset + df <- attr(X, "df") + segid <- as.integer(df$mapXY) + dfsub <- df[retainedges[segid], , drop=FALSE] + #' assign new serial numbers to retained segments + segmap <- cumsum(retainedges) + oldseg <- segid[retainedges[segid]] + newseg <- segmap[oldseg] + dfsub$mapXY <- newseg + ## adjust tp coordinate if segment endpoints were reversed + if(any(revseg <- reverse[newseg])) { + tp <- as.numeric(unlist(dfsub$tp)) + dfsub$tp[revseg] <- 1 - tp[revseg] + } + ## make new linim object + Y <- linim(Lsub, XimLsub, df=dfsub) + return(Y) + } else { + ## X is an lpp object + ## Find data points that lie on accepted segments + dat <- X$data # hyperframe, may include marks + ok <- retainedges[unlist(dat$seg)] + dsub <- dat[ok, , drop=FALSE] + ## compute new serial numbers for retained segments + segmap <- cumsum(retainedges) + oldseg <- as.integer(unlist(dsub$seg)) + dsub$seg <- newseg <- segmap[oldseg] + ## adjust tp coordinate if segment endpoints were reversed + if(any(revseg <- reverse[newseg])) { + tp <- as.numeric(unlist(dsub$tp)) + dsub$tp[revseg] <- 1 - tp[revseg] + } + ## make new lpp object + Y <- ppx(data=dsub, domain=Lsub, coord.type=as.character(X$ctype)) + class(Y) <- c("lpp", class(Y)) + ## tack on information about subset + attr(Y, "retainpoints") <- ok } - # make new lpp object - Y <- ppx(data=dsub, domain=Lsub, coord.type=as.character(X$ctype)) - class(Y) <- c("lpp", class(Y)) - ## tack on information about subset - attr(Y, "retainpoints") <- ok return(Y) } diff --git a/inst/doc/packagesizes.txt b/inst/doc/packagesizes.txt index e2d9891..d31631e 100755 --- a/inst/doc/packagesizes.txt +++ b/inst/doc/packagesizes.txt @@ -32,4 +32,4 @@ date version nhelpfiles nobjects ndatasets Rlines srclines "2023-10-28" "3.1-3" 148 307 0 12268 3270 "2024-02-04" "3.1-4" 148 312 0 12340 3270 "2024-03-24" "3.1-5" 148 312 0 12343 3270 -"2024-05-01" "3.1-5.002" 148 312 0 12347 3270 +"2024-06-05" "3.1-5.003" 148 312 0 12373 3270 diff --git a/man/Extract.linim.Rd b/man/Extract.linim.Rd index 747c37d..9155ef6 100644 --- a/man/Extract.linim.Rd +++ b/man/Extract.linim.Rd @@ -55,6 +55,12 @@ Y[X] Y[square(c(0.3, 0.6))] } +\seealso{ + \code{\link{thinNetwork}} to extract the data + lying on selected edges of the network. + + \code{\link{linim}} to make a pixel image on a network. +} \author{ \adrian } diff --git a/man/thinNetwork.Rd b/man/thinNetwork.Rd index a8c4fb0..b2b1f9c 100644 --- a/man/thinNetwork.Rd +++ b/man/thinNetwork.Rd @@ -8,13 +8,14 @@ or related object. } \usage{ -thinNetwork(X, retainvertices, retainedges) +thinNetwork(X, retainvertices=NULL, retainedges=NULL) } \arguments{ \item{X}{ A linear network (object of class \code{"linnet"}), - or a point pattern on a linear network (object of class - \code{"lpp"}). + a point pattern on a linear network (object of class + \code{"lpp"}) or a pixel image on a linear network + (object of class \code{"linim"}). } \item{retainvertices}{ Optional. Subset index specifying which vertices should be retained @@ -60,6 +61,8 @@ thinNetwork(X, retainvertices, retainedges) occur, including renumbering of the segments and vertices. If \code{X} is a point pattern on a linear network, then data points will be deleted if they lie on a deleted edge. + If \code{X} is a pixel image on a linear network, then the image + will be restricted to the new sub-network. } \value{ An object of the same kind as \code{X}. diff --git a/tests/testsL.R b/tests/testsL.R index 8c3fba7..844a64e 100644 --- a/tests/testsL.R +++ b/tests/testsL.R @@ -195,7 +195,12 @@ local({ X0 <- insertVertices(X, x=numeric(0), y=numeric(0)) ## vertices on boundary of new window LL <- simplenet[boundingbox(vertices(simplenet))] - + + ## thinNetwork for lpp and linim + Xthin <- thinNetwork(X, retainedges=1:3) + D <- density(X, 0.1) + Dthin <- thinNetwork(D, retainedges=1:3) + ## Test [.lpp internal data B <- owin(c(0.1,0.7),c(0.19,0.6)) XB <- X[B]