Merge pull request #161 from r-spatial/n_comp

update igraph use; interrupt depth-first search in n.comp.nb, add igr…

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: spdep
-Version: 1.3-5
-Date: 2024-06-10
+Version: 1.3-6
+Date: 2024-06-12
 Title: Spatial Dependence: Weighting Schemes, Statistics
 Encoding: UTF-8
 Authors@R: c(person("Roger", "Bivand", role = c("cre", "aut"), 

NAMESPACE

@@ -83,7 +83,8 @@ export(grid2nb)
 export(autocov_dist)
 
 export(set.VerboseOption, get.VerboseOption, set.ZeroPolicyOption,
-        get.ZeroPolicyOption, get.SubgraphOption, set.SubgraphOption)
+        get.ZeroPolicyOption, get.SubgraphOption, set.SubgraphOption,
+        get.SubgraphCeiling, set.SubgraphCeiling)
 export(set.mcOption, get.mcOption, set.coresOption, get.coresOption,
         set.ClusterOption, get.ClusterOption)
 

NEWS.md

@@ -1,4 +1,8 @@
-# Version 1.3-5 (development)
+# Version 1.3-6 (development)
+
+* #160 handle `n.comp.nb` delay in `print.nb` and elsewhere when the total number of neighbours is large
+
+# Version 1.3-5 (2025-06-10)
 
 * #157 migrate ESRI Shapefile to GPKG files; convert bhicv.shp to GPKG 
 

R/AAA.R

@@ -12,7 +12,9 @@ assign("cores", NULL, envir = .spdepOptions)
 assign("cluster", NULL, envir = .spdepOptions)
 assign("rlecuyerSeed", rep(12345, 6), envir = .spdepOptions)
 assign("listw_is_CsparseMatrix", FALSE, envir = .spdepOptions)
-
+assign("cluster", NULL, envir = .spdepOptions)
+assign("report_nb_subgraphs", TRUE, envir = .spdepOptions)
+assign("nb_subgraphs_N+E", 100000L, envir = .spdepOptions)
 setOldClass(c("listw"))
 
 .onLoad <- function(lib, pkg) {

R/components.R

@@ -1,13 +1,32 @@
-# Copyright 2001 by Nicholas Lewin-Koh 
+# Copyright 2001 by Nicholas Lewin-Koh, igraph added RSB 2024
 #
 
 
 n.comp.nb <- function(nb.obj){
-  if(!inherits(nb.obj,"nb"))stop("not a neighbours list")
-  nb.obj <- make.sym.nb(nb.obj)
-  comp <- rep(0,length(nb.obj))
-  comp <- .Call("g_components", nb.obj, as.integer(comp), PACKAGE="spdep")
-  answ <- list(nc=length(unique(comp)), comp.id=comp)
+  if(!inherits(nb.obj,"nb")) stop("not a neighbours list")
+  if (sum(card(nb.obj)) == 0L) {
+    return(list(nc=length(nb.obj), comp.id=1:length(nb.obj)))
+  }
+  nb.sym <- is.symmetric.nb(nb.obj)
+  igraph <- FALSE
+  if (requireNamespace("igraph", quietly=TRUE) &&
+      requireNamespace("spatialreg", quietly=TRUE)) {
+      igraph <- TRUE
+  }
+  if (!igraph) {
+    if (!nb.sym) nb.obj <- make.sym.nb(nb.obj)
+    comp <- rep(0,length(nb.obj))
+    comp <- .Call("g_components", nb.obj, as.integer(comp), PACKAGE="spdep")
+    answ <- list(nc=length(unique(comp)), comp.id=comp)
+  } else {
+    stopifnot(requireNamespace("igraph", quietly=TRUE))
+    stopifnot(requireNamespace("spatialreg", quietly=TRUE))
+    B <- as(nb2listw(nb.obj, style="B", zero.policy=TRUE), "CsparseMatrix")
+    g1 <- igraph::graph_from_adjacency_matrix(B,
+      mode=ifelse(nb.sym, "undirected", "directed"))
+    c1 <- igraph::components(g1, mode="weak")
+    answ <- list(nc=c1$no, comp.id=unname(c1$membership))
+  }
   answ
 }
 

R/diffnb.R

@@ -31,9 +31,11 @@ diffnb <- function(x, y, verbose=NULL) {
 	attr(res, "region.id") <- attr(x, "region.id")
 	attr(res, "call") <- match.call()
 	res <- sym.attr.nb(res)
-        if (get.SubgraphOption()) {
-          nsg <- n.comp.nb(res)$nc
-          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- n + sum(card(res))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(res)
+          attr(res, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
 	res
 }	

R/dnearneigh.R

@@ -124,9 +124,11 @@ dnearneigh <- function(x, d1, d2, row.names=NULL, longlat=NULL, bounds=c("GE", "
     attr(z, "nbtype") <- "distance"
     if (symtest) z <- sym.attr.nb(z)
     else attr(z, "sym") <- TRUE
-    if (get.SubgraphOption()) {
-        nsg <- n.comp.nb(z)$nc
-        if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+    NE <- np + sum(card(z))
+    if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+      ncomp <- n.comp.nb(z)
+      attr(z, "ncomp") <- ncomp
+      if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
     }
     z
 }

R/droplinks.R

@@ -30,9 +30,11 @@ droplinks <- function(nb, drop, sym=TRUE) {
 		nb[[i]] <- 0L
 	}
 	nb <- sym.attr.nb(nb)
-        if (get.SubgraphOption()) {
-            nsg <- n.comp.nb(nb)$nc
-            if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- n + sum(card(nb))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+            ncomp <- n.comp.nb(nb)
+            attr(nb, "ncomp") <- ncomp
+            if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
 	nb
 }

R/edit.nb.R

@@ -162,9 +162,11 @@ edit.nb <- function(name, coords, polys=NULL, ..., use_region.id=FALSE) {
   if (is.null(icl)) class(nb) <- "nb"
   else class(nb) <- c("nb", icl)
   nb <- sym.attr.nb(nb)
-  if (get.SubgraphOption()) {
-     nsg <- n.comp.nb(nb)$nc
-     if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+  NE <- n + sum(card(nb))
+  if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+    ncomp <- n.comp.nb(nb)
+    attr(z, "ncomp") <- ncomp
+    if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
   }
   nb
 }

R/graph2nb.R

@@ -31,9 +31,11 @@ graph2nb <- function(gob, row.names=NULL,sym=FALSE) {
  	attr(res, "type") <- attr(gob, "type")
 	class(res) <- "nb"
 	res <- sym.attr.nb(res)
-        if (get.SubgraphOption()) {
-          nsg <- n.comp.nb(res)$nc
-          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- length(res) + sum(card(res))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(res)
+          attr(res, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
 	res
 }

R/knn2nb.R

@@ -27,9 +27,11 @@ knn2nb <- function(knn, row.names=NULL, sym=FALSE) {
 	attr(res, "type") <- "knn"
  	attr(res, "knn-k") <- knn$k
 	class(res) <- "nb"
-        if (get.SubgraphOption()) {
-          nsg <- n.comp.nb(res)$nc
-          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- length(res) + sum(card(res))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(res)
+          attr(res, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
 	res
 }

R/nb2blocknb.R

@@ -47,9 +47,11 @@ nb2blocknb <- function(nb=NULL, ID, row.names = NULL) {
 	attr(res, "block") <- TRUE
 	attr(res, "call") <- match.call()
 	res <- sym.attr.nb(res)
-        if (get.SubgraphOption()) {
-          nsg <- n.comp.nb(res)$nc
-          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- length(res) + sum(card(res))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(res)
+          attr(res, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
 	res
 }

R/nblag.R

@@ -38,10 +38,12 @@ nblag <- function(neighbours, maxlag)
 		class(lags[[i]]) <- "nb"
 		attr(lags[[i]], "region.id") <- attr(neighbours, "region.id")
 		lags[[i]] <- sym.attr.nb(lags[[i]])
-                if (get.SubgraphOption()) {
-                  nsg <- n.comp.nb(lags[[i]])$nc
-                  if (nsg > 1)
-                    warning("neighbour object ", i, " has ", nsg, " sub-graphs")
+                NE <- length(lags[[i]]) + sum(card(lags[[i]]))
+                if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+                    ncomp <- n.comp.nb(lags[[i]])
+                    attr(lags[[i]], "ncomp") <- ncomp
+                    if (ncomp$nc > 1) warning("lag ", i,
+                        " neighbour object has ", ncomp$nc, " sub-graphs")
                 }
 	}
 	attr(lags, "call") <- match.call()

R/nboperations.R

@@ -28,9 +28,11 @@ union.nb<-function(nb.obj1, nb.obj2){
   attr(new.nb,"type")<-paste("union(",attr(nb.obj1,"type"),
                              ",",attr(nb.obj2,"type"),")")
   class(new.nb)<-"nb"
-  if (get.SubgraphOption()) {
-    nsg <- n.comp.nb(new.nb)$nc
-    if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+  NE <- length(new.nb) + sum(card(new.nb))
+  if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+    ncomp <- n.comp.nb(new.nb)
+    attr(new.nb, "ncomp") <- ncomp
+    if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
   }
   new.nb
  }
@@ -59,9 +61,11 @@ intersect.nb<-function(nb.obj1, nb.obj2){
   attr(new.nb,"type")<-paste("intersect(",attr(nb.obj1,"type"),
                              ",",attr(nb.obj2,"type"),")")
   class(new.nb)<-"nb"
-  if (get.SubgraphOption()) {
-    nsg <- n.comp.nb(new.nb)$nc
-    if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+  NE <- length(new.nb) + sum(card(new.nb))
+  if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+    ncomp <- n.comp.nb(new.nb)
+    attr(new.nb, "ncomp") <- ncomp
+    if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
   }
   new.nb
 }
@@ -107,9 +111,11 @@ setdiff.nb<-function(nb.obj1, nb.obj2){
   	attr(new.nb,"type")<-paste("setdiff(",attr(nb.obj1,"type"),
                              ",",attr(nb.obj2,"type"),")")
   	class(new.nb)<-"nb"
-        if (get.SubgraphOption()) {
-          nsg <- n.comp.nb(new.nb)$nc
-          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- length(new.nb) + sum(card(new.nb))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(new.nb)
+          attr(new.nb, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
   	new.nb
 }
@@ -134,9 +140,11 @@ complement.nb<-function(nb.obj){
   }
   attr(new.nb,"type")<-paste("complement(",attr(nb.obj,"type"),")")
   class(new.nb)<-"nb"
-  if (get.SubgraphOption()) {
-    nsg <- n.comp.nb(new.nb)$nc
-    if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+  NE <- length(new.nb) + sum(card(new.nb))
+  if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+    ncomp <- n.comp.nb(new.nb)
+    attr(new.nb, "ncomp") <- ncomp
+    if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
   }
   new.nb
  }

R/poly2nb.R

@@ -200,9 +200,11 @@ poly2nb <- function(pl, row.names=NULL, snap=sqrt(.Machine$double.eps),
 	if (queen) attr(ans, "type") <- "queen"
 	else attr(ans, "type") <- "rook"
 	ans <- sym.attr.nb(ans)
-        if (get.SubgraphOption()) {
-          nsg <- n.comp.nb(ans)$nc
-          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- n + sum(card(ans))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(ans)
+          attr(ans, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
         if (verbose) cat("done:", (proc.time() - .ptime_start)[3], "\n")
         .ptime_start <- proc.time()

R/read.gal.R

@@ -64,9 +64,11 @@ read.gal <- function(file, region.id=NULL, override.id=FALSE)
 	attr(res1, "gal") <- TRUE
 	attr(res1, "call") <- TRUE
 	res1 <- sym.attr.nb(res1)
-        if (get.SubgraphOption()) {
-          nsg <- n.comp.nb(res1)$nc
-          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- length(res1) + sum(card(res1))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(res1)
+          attr(res1, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
 	res1
 }

R/read.gwt2nb.R

@@ -72,9 +72,11 @@ read.gwt2nb <- function(file, region.id=NULL) {
 	attr(res, "call") <- match.call()
 	attr(res, "n") <- n
 	res <- sym.attr.nb(res)
-        if (get.SubgraphOption()) {
-          nsg <- n.comp.nb(res)$nc
-          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        NE <- length(res) + sum(card(res))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(res)
+          attr(res, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
         }
 	res
 }

R/spChkOption.R

@@ -1,10 +1,10 @@
-# Copyright 2003-2015 by Roger Bivand 
+# Copyright 2003-2024 by Roger Bivand 
 
 set.listw_is_CsparseMatrix_Option <- function(check) {
 	if (!is.logical(check)) stop ("logical argument required")
 	res <- get("listw_is_CsparseMatrix", envir = .spdepOptions)
 	assign("listw_is_CsparseMatrix", check, envir = .spdepOptions)
-	res
+	invisible(res)
 }
 
 get.listw_is_CsparseMatrix_Option <- function() {
@@ -15,7 +15,7 @@ set.spChkOption <- function(check) {
 	if (!is.logical(check)) stop ("logical argument required")
 	res <- get("spChkID", envir = .spdepOptions)
 	assign("spChkID", check, envir = .spdepOptions)
-	res
+	invisible(res)
 }
 
 get.spChkOption <- function() {
@@ -26,7 +26,7 @@ set.VerboseOption <- function(check) {
 	if (!is.logical(check)) stop ("logical argument required")
 	res <- get("verbose", envir = .spdepOptions)
 	assign("verbose", check, envir = .spdepOptions)
-	res
+	invisible(res)
 }
 
 get.SubgraphOption <- function() {
@@ -37,9 +37,21 @@ set.SubgraphOption <- function(check) {
 	if (!is.logical(check)) stop ("logical argument required")
 	res <- get("report_nb_subgraphs", envir = .spdepOptions)
 	assign("report_nb_subgraphs", check, envir = .spdepOptions)
-	res
+	invisible(res)
+}
+
+get.SubgraphCeiling <- function() {
+	get("nb_subgraphs_N+E", envir = .spdepOptions)
 }
 
+set.SubgraphCeiling <- function(value) {
+	if (!is.integer(value)) stop ("integer argument required")
+	res <- get("nb_subgraphs_N+E", envir = .spdepOptions)
+	assign("nb_subgraphs_N+E", value, envir = .spdepOptions)
+	invisible(res)
+}
+
+
 get.VerboseOption <- function() {
 	get("verbose", envir = .spdepOptions)
 }
@@ -48,7 +60,7 @@ set.ZeroPolicyOption <- function(check) {
 	if (!is.logical(check)) stop ("logical argument required")
 	res <- get("zeroPolicy", envir = .spdepOptions)
 	assign("zeroPolicy", check, envir = .spdepOptions)
-	res
+	invisible(res)
 }
 
 get.ZeroPolicyOption <- function() {
@@ -76,7 +88,7 @@ set.mcOption <- function(value) {
         } else {
 	    assign("mc", value, envir = .spdepOptions)
         }
-	res
+	invisible(res)
 }
 
 get.mcOption  <- function() {
@@ -93,7 +105,7 @@ set.coresOption <- function(value) {
             stopifnot(!is.na(value))
 	    assign("cores", value, envir = .spdepOptions)
         }
-	res
+	invisible(res)
 }
 
 get.coresOption  <- function() {