diff --git a/R/listw2sn.R b/R/listw2sn.R index 1569577c..890a6555 100644 --- a/R/listw2sn.R +++ b/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")))) diff --git a/R/nb2listw.R b/R/nb2listw.R index 9a362d37..a94c5d2e 100644 --- a/R/nb2listw.R +++ b/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}) diff --git a/R/nb2mat.R b/R/nb2mat.R index 21e92d72..d0ff9e9b 100644 --- a/R/nb2mat.R +++ b/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) diff --git a/R/tolerance.nb.R b/R/tolerance.nb.R index ea35d6e2..fc04956c 100644 --- a/R/tolerance.nb.R +++ b/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) { diff --git a/man/mat2listw.Rd b/man/mat2listw.Rd index cd416a5c..9aad3c58 100644 --- a/man/mat2listw.Rd +++ b/man/mat2listw.Rd @@ -37,18 +37,20 @@ 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) { @@ -56,7 +58,7 @@ 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) } }