tolerance.nb drops mat2listw; mat2listw hardened to zero.policy changes

R/listw2sn.R

@@ -43,7 +43,7 @@ sn2listw <- function(sn, style=NULL, zero.policy=NULL) {
 	attr(nlist, "region.id") <- region.id
 	vlist <- vector(mode="list", length=n)
 	rle.sn <- rle(sn[,1])
-	if (n != length(rle.sn$lengths)) {
+	if (!zero.policy && n != length(rle.sn$lengths)) {
             nnhits <- region.id[which(!(1:n %in% rle.sn$values))]
 	    warning(paste(paste(nnhits, collapse=", "),
                 ifelse(length(nnhits) < 2, "is not an origin",
@@ -67,8 +67,7 @@ sn2listw <- function(sn, style=NULL, zero.policy=NULL) {
 	class(res) <- c("listw", "nb")
         if (any(card(res$neighbours) == 0L)) {
             if (!zero.policy) {
-                warning("no-neighbour observations found, zero.policy set to TRUE")
-                zero.policy <- !zero.policy
+                stop("no-neighbour observations found, set zero.policy to TRUE")
             }
         }
 	if (!(is.null(attr(sn, "GeoDa"))))

R/nb2listw.R

@@ -29,7 +29,7 @@ nb2listw <- function(neighbours, glist=NULL, style="W", zero.policy=NULL)
 			stop("neighbours and glist do not conform")
 		if (any(is.na(unlist(glist))))
 			stop ("NAs in general weights list")
-		if (any(sapply(glist, function(x) 
+		if (!zero.policy && any(sapply(glist, function(x) 
 			isTRUE(all.equal(sum(x), 0)))))
 			warning("zero sum general weights") 
 		glist <- lapply(glist, function(x) {mode(x) <- "numeric"; x})

R/nb2mat.R

@@ -72,7 +72,7 @@ mat2listw <- function(x, row.names=NULL, style=NULL, zero.policy=NULL) {
             class(df) <- c(class(df), "spatial.neighbour")
             attr(df, "region.id") <- row.names
             attr(df, "n") <- dim(xC)[1]
-            res <- sn2listw(df)
+            res <- sn2listw(df, style=style, zero.policy=zero.policy)
             neighbours <- res$neighbours
             weights <- res$weights
         } else {
@@ -96,8 +96,7 @@ mat2listw <- function(x, row.names=NULL, style=NULL, zero.policy=NULL) {
 		verbose=FALSE, force=TRUE)
         if (any(card(neighbours) == 0L)) {
             if (!zero.policy) {
-                warning("no-neighbour observations found, zero.policy set to TRUE")
-                zero.policy <- !zero.policy
+                stop("no-neighbour observations found, set zero.policy to TRUE")
             }
         }
 	res <- list(style=style, neighbours=neighbours, weights=weights)

R/tolerance.nb.R

@@ -68,11 +68,48 @@ function (coords, unit.angle = "degrees", max.dist, tolerance, rot.angle, plot.s
 		}
 	}
 
-	nb.obj <- mat2listw(angles)$neighbours
+	nb.obj <- mat2nb(angles)
 
 	return(nb.obj)
 }
 
+mat2nb <- function(x, row.names=NULL) {
+    	n <- nrow(x)
+	if (n < 1) stop("non-positive number of entities")
+	m <- ncol(x)
+	if (n != m) stop("x must be a square matrix")
+	if (any(x < 0)) stop("values in x cannot be negative")
+	if (any(is.na(x))) stop("NA values in x not allowed")
+    	if (!is.null(row.names)) {
+	    if(length(row.names) != n)
+            	stop("row.names wrong length")
+	    if (length(unique(row.names)) != length(row.names))
+	    	stop("non-unique row.names given")
+    	}
+    	if (is.null(row.names)) {
+	    if (!is.null(row.names(x))) {
+		row.names <- row.names(x)
+	    } else {
+		row.names <- as.character(1:n)
+	    }
+	}
+	neighbours <- vector(mode="list", length=n)
+	for (i in 1:n) {
+	    nbs  <- which(x[i,] > 0.0)
+	    if (length(nbs) > 0) {
+		neighbours[[i]] <- nbs
+	    } else {
+		neighbours[[i]] <- 0L
+	    }
+        }
+	class(neighbours) <- "nb"
+	attr(neighbours, "region.id") <- row.names
+ 	attr(neighbours, "call") <- NA
+        attr(neighbours, "sym") <- is.symmetric.nb(neighbours, 
+		verbose=FALSE, force=TRUE)
+        neighbours
+}
+
 `find.angles` <-
 function (coords)
 {

man/mat2listw.Rd

@@ -37,26 +37,28 @@ columbus <- st_read(system.file("shapes/columbus.shp", package="spData")[1], qui
 col005 <- dnearneigh(st_coordinates(st_centroid(st_geometry(columbus),
  of_largest_polygon=TRUE)), 0, 0.5, as.character(columbus$NEIGNO))
 summary(col005)
-col005.w.mat <- nb2mat(col005, zero.policy=TRUE)
-col005.w.b <- mat2listw(col005.w.mat)
+col005.w.mat <- nb2mat(col005, style="W", zero.policy=TRUE)
+try(col005.w.b <- mat2listw(col005.w.mat, style="W"))
+col005.w.b <- mat2listw(col005.w.mat, style="W", zero.policy=TRUE)
 summary(col005.w.b$neighbours)
 diffnb(col005, col005.w.b$neighbours)
 col005.w.mat.3T <- kronecker(diag(3), col005.w.mat)
-col005.w.b.3T <- mat2listw(col005.w.mat.3T, style="W")
+col005.w.b.3T <- mat2listw(col005.w.mat.3T, style="W", zero.policy=TRUE)
 summary(col005.w.b.3T$neighbours)
 run <- FALSE
 if (require("spatialreg", quiet=TRUE)) run <- TRUE
 if (run) {
 W <- as(nb2listw(col005, style="W", zero.policy=TRUE), "CsparseMatrix")
-col005.spM <- mat2listw(W)
+try(col005.spM <- mat2listw(W))
+col005.spM <- mat2listw(W, style="W", zero.policy=TRUE)
 summary(col005.spM$neighbours)
 }
 if (run) {
 diffnb(col005, col005.spM$neighbours)
 }
 if (run && require("Matrix", quiet=TRUE)) {
 IW <- kronecker(Diagonal(3), W)
-col005.spM.3T <- mat2listw(as(IW, "CsparseMatrix"), style="W")
+col005.spM.3T <- mat2listw(as(IW, "CsparseMatrix"), style="W", zero.policy=TRUE)
 summary(col005.spM.3T$neighbours)
 }
 }