thinNetwork now handles linim objects

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"),

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'.
 

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,36 +305,59 @@ 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))
     marks(Lsub$lines) <- marksubset(edgemarks, 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)
 }
 

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

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
 }

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}.

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]