r-spatial/discuss#62 progress

NAMESPACE

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

NEWS.md

@@ -1,5 +1,7 @@
 # Version 1.3-1 (development)
 
+* functions creating `nb` objects now warn if the object has a sub-graph count of > 1 and  `get.SubgraphOption` is `TRUE` (default `FALSE`): `complement.nb`, `diffnb`, `dnearneigh`, `droplinks`, `edit.nb`, `graph2nb`, `knn2nb`, `nb2blocknb`, `nblag`, `nblag_cumul`, `poly2nb`, `read.gal`, `read.gwt2nb`, `setdiff.nb`, `tolerance.nb`, `tri2nb`, `union.nb`
+
 * `summary.nb`, `print.nb`, `summary.listw` and `print.listw` now report the subgraph count from `n.comp.nb` if it is more than one
 
 * `subset.nb` now reports if the subgraph count of the neighbour object increases on subsetting

R/AAA.R

@@ -4,6 +4,7 @@
 .spdepOptions <- new.env(FALSE, globalenv())
 assign("spChkID", FALSE, envir = .spdepOptions)
 assign("zeroPolicy", FALSE, envir = .spdepOptions)
+assign("report_nb_subgraphs", FALSE, envir = .spdepOptions)
 assign("verbose", FALSE, envir = .spdepOptions)
 assign("mc", ifelse(.Platform$OS.type == "windows", FALSE, TRUE),
  envir = .spdepOptions)

R/diffnb.R

@@ -31,6 +31,10 @@ 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")
+        }
 	res
 }	
 

R/dnearneigh.R

@@ -123,6 +123,10 @@ 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")
+    }
     z
 }
 

R/droplinks.R

@@ -30,6 +30,10 @@ 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")
+        }
 	nb
 }
 

R/edit.nb.R

@@ -162,6 +162,10 @@ 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")
+  }
   nb
 }
 

R/graph2nb.R

@@ -31,5 +31,9 @@ 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")
+        }
 	res
 }

R/knn2nb.R

@@ -27,5 +27,9 @@ 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")
+        }
 	res
 }

R/nb2blocknb.R

@@ -47,6 +47,10 @@ 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")
+        }
 	res
 }
 

R/nblag.R

@@ -38,6 +38,11 @@ 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")
+                }
 	}
 	attr(lags, "call") <- match.call()
 	lags
@@ -67,5 +72,9 @@ nblag_cumul <- function (nblags) {
     attr(lags, "region.id") <- attr(nblags[[1]], "region.id")
     attr(lags, "call") <- match.call()
     class(lags) <- "nb"
+    if (get.SubgraphOption()) {
+        nsg <- n.comp.nb(lags)$nc
+        if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+    }
     lags
 }

R/nboperations.R

@@ -28,6 +28,10 @@ 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")
+  }
   new.nb
  }
 
@@ -55,6 +59,10 @@ 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")
+  }
   new.nb
 }
 setdiff.nb<-function(nb.obj1, nb.obj2){
@@ -99,6 +107,10 @@ 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")
+        }
   	new.nb
 }
 
@@ -122,5 +134,9 @@ 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")
+  }
   new.nb
  }

R/poly2nb.R

@@ -200,6 +200,10 @@ 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")
+        }
         if (verbose) cat("done:", (proc.time() - .ptime_start)[3], "\n")
         .ptime_start <- proc.time()
 	ans

R/read.gal.R

@@ -64,6 +64,10 @@ 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")
+        }
 	res1
 }
 

R/read.gwt2nb.R

@@ -72,6 +72,10 @@ 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")
+        }
 	res
 }
 

R/spChkOption.R

@@ -29,6 +29,17 @@ set.VerboseOption <- function(check) {
 	res
 }
 
+get.SubgraphOption <- function() {
+	get("report_nb_subgraphs", envir = .spdepOptions)
+}
+
+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
+}
+
 get.VerboseOption <- function() {
 	get("verbose", envir = .spdepOptions)
 }

R/tolerance.nb.R

@@ -107,6 +107,10 @@ mat2nb <- function(x, row.names=NULL) {
  	attr(neighbours, "call") <- NA
         attr(neighbours, "sym") <- is.symmetric.nb(neighbours, 
 		verbose=FALSE, force=TRUE)
+        if (get.SubgraphOption()) {
+          nsg <- n.comp.nb(neighbours)$nc
+          if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        }
         neighbours
 }
 

R/tri2nb.R

@@ -51,6 +51,10 @@ tri2nb <- function(coords, row.names = NULL) {
 	attr(nb, "tri") <- TRUE
 	attr(nb, "call") <- match.call()
 	nb <- sym.attr.nb(nb)
+        if (get.SubgraphOption()) {
+            nsg <- n.comp.nb(nb)$nc
+            if (nsg > 1) warning("neighbour object has ", nsg, " sub-graphs")
+        }
 	nb
 }
 

inst/tinytest/test_subgraph_warning.R

@@ -0,0 +1,12 @@
+library(spdep)
+library(sf)
+columbus <- st_read(system.file("shapes/columbus.shp", package="spData")[1], quiet=TRUE)
+col_geoms <- st_geometry(columbus)
+col_geoms[21] <- st_buffer(col_geoms[21], dist=-0.05)
+st_geometry(columbus) <- col_geoms
+expect_false(get.SubgraphOption())
+expect_silent(nb <- poly2nb(columbus))
+set.SubgraphOption(TRUE)
+expect_true(get.SubgraphOption())
+expect_warning(nb <- poly2nb(columbus))
+

man/autocov_dist.Rd

@@ -26,7 +26,7 @@ autocov_dist(z, xy, nbs = 1, type = "inverse", zero.policy = NULL,
 
 \note{The validity of this approach strongly hinges on the correct choice of the
 neighbourhood scheme! Using \option{style="B"} ensures symmetry of the
-neighbourhood matrix (i.e. w_{nm} = w_{mn}). Please see Bardos et al. (2015)
+neighbourhood matrix (i.e. \eqn{w_{nm} = w_{mn}}). Please see Bardos et al. (2015)
 for details.}
 
 \references{Augustin N.H., Mugglestone M.A. and Buckland S.T. (1996) An autologistic model for the spatial distribution of wildlife. \emph{Journal of Applied Ecology}, 33, 339-347; Gumpertz M.L., Graham J.M. and Ristaino J.B. (1997) Autologistic model of spatial pattern of Phytophthora epidemic in bell pepper: effects of soil variables on disease presence. \emph{Journal of Agricultural, Biological and Environmental Statistics}, 2, 131-156; Bardos, D.C., Guillera-Arroita, G. and Wintle, B.A. (2015) Valid auto-models for spatially autocorrelated occupancy and abundance data. arXiv, 1501.06529.}

man/card.Rd

@@ -17,7 +17,7 @@ An integer vector of the numbers of neighbours of regions in the neighbours
 list.
 }
 
-\details{\dQuote{nb} objects are stored as lists of integer vectors, where the vectors contain either the indices in the range \code{1:n} for \code{n} as {length(nb)} of the neighbours of region \code{i}, or \code{as.integer(0)} to signal no neighbours. The function \code{card(nb)} is used to extract the numbers of neighbours from the \dQuote{nb} object.}
+\details{\dQuote{nb} objects are stored as lists of integer vectors, where the vectors contain either the indices in the range \code{1:n} for \code{n} as \code{length(nb)} of the neighbours of region \code{i}, or \code{as.integer(0)} to signal no neighbours. The function \code{card(nb)} is used to extract the numbers of neighbours from the \dQuote{nb} object.}
 
 
 \references{Bivand R, Pebesma EJ, Gomez-Rubio V, (2008) \emph{Applied Spatial Data Analysis with R}, Springer, New York, pp. 239-251; Bivand R, Portnov B, (2004) Exploring spatial data analysis techniques using R: the case of observations with no neighbours. In: Anselin L, Florax R, Rey S, (eds.), \emph{Advances in Spatial Econometrics, Methodology, Tools and Applications}. Berlin: Springer-Verlag, pp. 121-142.}

man/set.spChkOption.Rd

@@ -5,14 +5,16 @@
 \alias{spNamedVec}
 \alias{set.VerboseOption}
 \alias{get.VerboseOption}
+\alias{set.SubgraphOption}
+\alias{get.SubgraphOption}
 \alias{set.ZeroPolicyOption}
 \alias{get.ZeroPolicyOption}
 \alias{set.listw_is_CsparseMatrix_Option}
 \alias{get.listw_is_CsparseMatrix_Option}
 %- Also NEED an `\alias' for EACH other topic documented here.
 \title{Control checking of spatial object IDs}
 \description{
-  Provides support for checking the mutual integrity of spatial neighbour weights and spatial data; similar mechanisms are used for passing global verbose and zero.policy options, and for providing access to a running cluster for embarrassingly parallel tasks. 
+  Provides support for checking the mutual integrity of spatial neighbour weights and spatial data; similar mechanisms are used for passing global verbose and zero.policy options, and for causing functions creating neighbour objects to warn if there are multiple subgraphs. 
 }
 \usage{
 set.spChkOption(check)
@@ -23,6 +25,8 @@ set.VerboseOption(check)
 get.VerboseOption()
 set.ZeroPolicyOption(check)
 get.ZeroPolicyOption()
+set.SubgraphOption(check)
+get.SubgraphOption()
 set.listw_is_CsparseMatrix_Option(check)
 get.listw_is_CsparseMatrix_Option()
 }