diff --git a/NAMESPACE b/NAMESPACE index 6ad80465..640d160f 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 429d6fc5..8623f72a 100644 --- a/NEWS.md +++ b/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 diff --git a/R/AAA.R b/R/AAA.R index 2d9a4c20..818d7c3e 100644 --- a/R/AAA.R +++ b/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) diff --git a/R/diffnb.R b/R/diffnb.R index acf62aba..72cdbb80 100644 --- a/R/diffnb.R +++ b/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 } diff --git a/R/dnearneigh.R b/R/dnearneigh.R index 13d1ebad..5264eb39 100644 --- a/R/dnearneigh.R +++ b/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 } diff --git a/R/droplinks.R b/R/droplinks.R index a97e4d66..4f6ecda0 100644 --- a/R/droplinks.R +++ b/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 } diff --git a/R/edit.nb.R b/R/edit.nb.R index 5a4def48..f60ab01d 100644 --- a/R/edit.nb.R +++ b/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 } diff --git a/R/graph2nb.R b/R/graph2nb.R index 6391c6c7..b6572d17 100644 --- a/R/graph2nb.R +++ b/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 } diff --git a/R/knn2nb.R b/R/knn2nb.R index 31e84cb5..cc44f5b6 100644 --- a/R/knn2nb.R +++ b/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 } diff --git a/R/nb2blocknb.R b/R/nb2blocknb.R index a6bd5c24..8a2897f1 100644 --- a/R/nb2blocknb.R +++ b/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 } diff --git a/R/nblag.R b/R/nblag.R index 1a6d2e95..1b70f720 100644 --- a/R/nblag.R +++ b/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 } diff --git a/R/nboperations.R b/R/nboperations.R index 9a73314a..e76c2355 100644 --- a/R/nboperations.R +++ b/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 } diff --git a/R/poly2nb.R b/R/poly2nb.R index ed741dda..ba6c046a 100644 --- a/R/poly2nb.R +++ b/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 diff --git a/R/read.gal.R b/R/read.gal.R index ccd1b0e5..4afc3724 100644 --- a/R/read.gal.R +++ b/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 } diff --git a/R/read.gwt2nb.R b/R/read.gwt2nb.R index 01950f61..eb6101fb 100644 --- a/R/read.gwt2nb.R +++ b/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 } diff --git a/R/spChkOption.R b/R/spChkOption.R index f786e1ff..b5e6bda3 100644 --- a/R/spChkOption.R +++ b/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) } diff --git a/R/tolerance.nb.R b/R/tolerance.nb.R index fc04956c..a5efeb9f 100644 --- a/R/tolerance.nb.R +++ b/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 } diff --git a/R/tri2nb.R b/R/tri2nb.R index 206a46fa..53234d13 100644 --- a/R/tri2nb.R +++ b/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 } diff --git a/inst/tinytest/test_subgraph_warning.R b/inst/tinytest/test_subgraph_warning.R new file mode 100644 index 00000000..cd296171 --- /dev/null +++ b/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)) + diff --git a/man/autocov_dist.Rd b/man/autocov_dist.Rd index 055bc9e8..49346e1c 100644 --- a/man/autocov_dist.Rd +++ b/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.} diff --git a/man/card.Rd b/man/card.Rd index a5f34bb5..e547511e 100644 --- a/man/card.Rd +++ b/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.} diff --git a/man/set.spChkOption.Rd b/man/set.spChkOption.Rd index 3a63d972..8de750ee 100644 --- a/man/set.spChkOption.Rd +++ b/man/set.spChkOption.Rd @@ -5,6 +5,8 @@ \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} @@ -12,7 +14,7 @@ %- 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() }