add zero.policy attribute to listw objects

r-spatial · Nov 4, 2023 · e159de9 · e159de9
1 parent 0a70aa2
commit e159de9
Show file tree

Hide file tree

Showing 63 changed files with 294 additions and 164 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: spdep
-Version: 1.2-9
-Date: 2023-09-23
+Version: 1.3-1
+Date: 2023-11-03
 Title: Spatial Dependence: Weighting Schemes, Statistics
 Encoding: UTF-8
 Authors@R: c(person("Roger", "Bivand", role = c("cre", "aut"), 

diff --git a/NAMESPACE b/NAMESPACE
@@ -48,8 +48,8 @@ export(listw2sn, sn2listw, read.gwt2nb,	write.sn2gwt, lm.LMtests,
 	get.spChkOption, spNamedVec, tri2nb,
 	spweights.constants, lag.listw, listw2U, listw2star, is.symmetric.nb,
 	sym.attr.nb, include.self, make.sym.nb, union.nb, intersect.nb,
-	setdiff.nb, complement.nb, Szero, spdep, print.nb, summary.nb,
-	plot.nb, edit.nb, subset.nb, summary.listw, print.listw, subset.listw,
+	setdiff.nb, complement.nb, Szero, spdep,
+	plot.nb, edit.nb, subset.nb, subset.listw,
 	plot.Gabriel, plot.relative, print.jclist, print.LMtestlist,
 	plot.mc.sim, as.data.frame.localmoransad, print.localmoransad,
 	summary.localmoransad, print.summary.localmoransad, print.moransad,
@@ -91,12 +91,14 @@ export(localmoran_bv, moran_bv,local_joincount_uni, local_joincount_bv)
 
 S3method(print, nb)
 S3method(summary, nb)
+S3method(print, summary.nb)
 S3method(plot, nb)
 S3method(edit, nb)
 S3method(subset, nb)
 S3method(aggregate, nb)
 
 S3method(summary, listw)
+S3method(print, summary.listw)
 S3method(print, listw)
 S3method(plot, listw)
 S3method(subset, listw)

diff --git a/NEWS.md b/NEWS.md
@@ -1,6 +1,10 @@
-# Version 1.2-9 (development)
+# Version 1.3-1 (development)
 
-* adding a `zero.policy` attribute to functions creating `listw` objects: `nb2listw`
+* `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
+
+* adding a `zero.policy` attribute to functions creating `listw` objects: `nb2listw`, `sn2listw`, `mat2listw`, `nb2listwdist`. Default `zero.policy=` argument updated to use `attr(., "zero.policy")` in `summary.listw`, `print.listw`, `moran`, `moran.test`, `moran.mc`, `moran.plot`, `geary.mc`, `geary`, `geary.test`, `globalG.test`, `joincount.test`, `joincount.mc`, `joincount.multi`, `localC`, `localC_perm`, `localmoran`, `localmoran_perm`, `localG`, `localG_perm`, `lee`, `lee.test`, `lee.mc`, `lm.morantest`, `lm.LMtests`, `sp.mantel.mc`, `listw2star`, `lag.listw`, `lm.morantest`, `lm.LMtests`, `subset.listw`, `EBImoran.mc`, `LOSH`, `LOSH.mc`, `LOSH.cs`, `lm.morantest.exact`and `lm.morantest.sad`
 
 * confusing error message in `moran.plot()` if no-neighbour cases, but `zero.policy=FALSE`
 

diff --git a/R/EBI.R b/R/EBI.R
@@ -2,7 +2,7 @@
 # Addition of Martuzzi and Elliott Copyright 2006 Olaf Berke and Roger Bivand
 #
 
-EBImoran <- function (z, listw, nn, S0, zero.policy = NULL, subtract_mean_in_numerator=TRUE) 
+EBImoran <- function (z, listw, nn, S0, zero.policy = attr(listw, "zero.policy"), subtract_mean_in_numerator=TRUE) 
 {
 #default subtract_mean_in_numerator=TRUE 160219 RA
         if (is.null(zero.policy))
@@ -18,7 +18,7 @@ EBImoran <- function (z, listw, nn, S0, zero.policy = NULL, subtract_mean_in_num
     res
 }
 
-EBImoran.mc <- function (n, x, listw, nsim, zero.policy = NULL,
+EBImoran.mc <- function (n, x, listw, nsim, zero.policy = attr(listw, "zero.policy"),
  alternative = "greater", spChk = NULL, return_boot=FALSE, subtract_mean_in_numerator=TRUE) 
 {
 #default subtract_mean_in_numerator=TRUE 160219 RA

diff --git a/R/LOSH.R b/R/LOSH.R
@@ -1,4 +1,4 @@
-LOSH <- function(x, listw, a = 2, var_hi = TRUE, zero.policy = NULL, na.action = na.fail, spChk = NULL) {
+LOSH <- function(x, listw, a = 2, var_hi = TRUE, zero.policy = attr(listw, "zero.policy"), na.action = na.fail, spChk = NULL) {
   if (is.null(zero.policy)) 
     zero.policy <- get("zeroPolicy", envir = .spdepOptions)
   stopifnot(is.logical(zero.policy))

diff --git a/R/LOSH.cs.R b/R/LOSH.cs.R
@@ -1,4 +1,4 @@
-LOSH.cs <- function(x, listw, zero.policy = NULL, na.action = na.fail, 
+LOSH.cs <- function(x, listw, zero.policy = attr(listw, "zero.policy"), na.action = na.fail, 
                  p.adjust.method = "none", spChk = NULL) {
 
   stopifnot(is.vector(x))

diff --git a/R/LOSH.mc.R b/R/LOSH.mc.R
@@ -1,4 +1,4 @@
-LOSH.mc <- function(x, listw, a = 2, nsim = 99, zero.policy = NULL, na.action = na.fail, 
+LOSH.mc <- function(x, listw, a = 2, nsim = 99, zero.policy = attr(listw, "zero.policy"), na.action = na.fail, 
                     spChk = NULL, adjust.n = TRUE, p.adjust.method = "none") {
 
   stopifnot(is.vector(x))

diff --git a/R/geary.R b/R/geary.R
@@ -2,7 +2,7 @@
 #
 
 
-geary <- function(x, listw, n, n1, S0, zero.policy=NULL) {
+geary <- function(x, listw, n, n1, S0, zero.policy=attr(listw, "zero.policy")) {
         if (is.null(zero.policy))
             zero.policy <- get("zeroPolicy", envir = .spdepOptions)
         stopifnot(is.logical(zero.policy))
@@ -18,7 +18,7 @@ geary <- function(x, listw, n, n1, S0, zero.policy=NULL) {
 	res
 }
 
-geary.intern <- function(x, listw, n, zero.policy=NULL, type="geary") {
+geary.intern <- function(x, listw, n, zero.policy=attr(listw, "zero.policy"), type="geary") {
         if (is.null(zero.policy))
             zero.policy <- get("zeroPolicy", envir = .spdepOptions)
         stopifnot(is.logical(zero.policy))
@@ -33,7 +33,7 @@ geary.intern <- function(x, listw, n, zero.policy=NULL, type="geary") {
 	res
 }
 
-geary.test <- function(x, listw, randomisation=TRUE, zero.policy=NULL,
+geary.test <- function(x, listw, randomisation=TRUE, zero.policy=attr(listw, "zero.policy"),
     alternative="greater", spChk=NULL, adjust.n=TRUE) {
         if (is.null(zero.policy))
             zero.policy <- get("zeroPolicy", envir = .spdepOptions)
@@ -95,7 +95,7 @@ geary.test <- function(x, listw, randomisation=TRUE, zero.policy=NULL,
 	res
 }
 
-geary.mc <- function(x, listw, nsim, zero.policy=NULL,
+geary.mc <- function(x, listw, nsim, zero.policy=attr(listw, "zero.policy"),
 	alternative="greater", spChk=NULL, adjust.n=TRUE, return_boot=FALSE) {
         if (is.null(zero.policy))
             zero.policy <- get("zeroPolicy", envir = .spdepOptions)

diff --git a/R/globalG.R b/R/globalG.R
@@ -3,7 +3,7 @@
 # General G Statistics
 #
 #
-globalG.test <- function(x, listw, zero.policy=NULL,
+globalG.test <- function(x, listw, zero.policy=attr(listw, "zero.policy"),
 	alternative="greater", spChk=NULL, adjust.n=TRUE, B1correct=TRUE, adjust.x=TRUE, Arc_all_x=FALSE) {
         if (is.null(zero.policy))
             zero.policy <- get("zeroPolicy", envir = .spdepOptions)

diff --git a/R/jc.R b/R/jc.R
@@ -14,7 +14,7 @@ joincount <- function(dums, listw) {
 	res
 }
 
-joincount.test <- function(fx, listw, zero.policy=NULL,
+joincount.test <- function(fx, listw, zero.policy=attr(listw, "zero.policy"),
 	alternative="greater", sampling="nonfree",  
 	spChk=NULL, adjust.n=TRUE) {
         if (is.null(zero.policy))
@@ -107,11 +107,14 @@ print.jclist <- function(x, ...) {
 	invisible(x)
 }
 
-joincount.mc <- function(fx, listw, nsim, zero.policy=FALSE,
+joincount.mc <- function(fx, listw, nsim, zero.policy=attr(listw, "zero.policy"),
 	alternative="greater", spChk=NULL) {
 	alternative <- match.arg(alternative, c("greater", "less", "two.sided"))
 	if(!inherits(listw, "listw")) stop(paste(deparse(substitute(listw)),
 		"is not a listw object"))
+        if (is.null(zero.policy))
+            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+        stopifnot(is.logical(zero.policy))
 	if(!is.factor(fx)) stop(paste(deparse(substitute(fx)),
 		"is not a factor"))
 	if(missing(nsim)) stop("nsim must be given")
@@ -181,13 +184,16 @@ joincount.mc <- function(fx, listw, nsim, zero.policy=FALSE,
 
 
 
-joincount.multi <- function(fx, listw, zero.policy=FALSE, #adjust.n=TRUE,
+joincount.multi <- function(fx, listw, zero.policy=attr(listw, "zero.policy"), #adjust.n=TRUE,
 	spChk=NULL, adjust.n=TRUE) {
 	if(!inherits(listw, "listw")) stop(paste(deparse(substitute(listw)),
 		"is not a listw object"))
 	if(!is.factor(fx)) stop(paste(deparse(substitute(fx)),
 		"is not a factor"))
 	if (any(is.na(fx))) stop("NA in factor")
+        if (is.null(zero.policy))
+            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+        stopifnot(is.logical(zero.policy))
 	n <- length(listw$neighbours)
 	if (n != length(fx)) stop("objects of different length")
 	cards <- card(listw$neighbours)

diff --git a/R/lee.R b/R/lee.R
@@ -1,7 +1,7 @@
 #Lee (2001)'s bivariate association statistic
 #Based on code by Roger Bivand for moran's I
 
-lee <- function(x, y, listw, n, S2=NULL, zero.policy=NULL, NAOK=FALSE) {
+lee <- function(x, y, listw, n, S2=NULL, zero.policy=attr(listw, "zero.policy"), NAOK=FALSE) {
         if (is.null(zero.policy))
             zero.policy <- get("zeroPolicy", envir = .spdepOptions)
         stopifnot(is.logical(zero.policy))

diff --git a/R/lee.mc.R b/R/lee.mc.R
@@ -1,8 +1,8 @@
-# Copyright 20014 by Roger Bivand, Virgilio Gómez-Rubio
+# Copyright 2014 by Roger Bivand, Virgilio Gómez-Rubio
 #
 
 
-lee.mc <- function(x, y, listw, nsim, zero.policy=NULL,
+lee.mc <- function(x, y, listw, nsim, zero.policy=attr(listw, "zero.policy"),
 	alternative="greater", na.action=na.fail, spChk=NULL,
         return_boot=FALSE) {
 	alternative <- match.arg(alternative, c("greater", "less", "two.sided"))

diff --git a/R/lee.test.R b/R/lee.test.R
@@ -2,7 +2,7 @@
 #
 
 lee.test <- function(x, y, listw, #randomisation=TRUE, 
-	zero.policy=NULL,
+	zero.policy=attr(listw, "zero.policy"),
 	alternative="greater", 
 	#rank = FALSE, 
 	na.action=na.fail, spChk=NULL#, 

diff --git a/R/lisa_perm.R b/R/lisa_perm.R
@@ -84,7 +84,7 @@ probs_lut <- function(stat="I", nsim, alternative) {
     probs
 }
 
-localmoran_perm <- function(x, listw, nsim=499L, zero.policy=NULL,
+localmoran_perm <- function(x, listw, nsim=499L, zero.policy=attr(listw, "zero.policy"),
     na.action=na.fail, alternative = "two.sided",
     mlvar=TRUE, spChk=NULL, adjust.x=FALSE, sample_Ei=TRUE, iseed=NULL,
     no_repeat_in_row=FALSE) {
@@ -248,7 +248,7 @@ localmoran_perm <- function(x, listw, nsim=499L, zero.policy=NULL,
 # "localmoran" quadr mean/median/pysal "Low-Low", "Low-High", "High-Low", "High-High"
 
 
-localG_perm <- function(x, listw, nsim=499, zero.policy=NULL, spChk=NULL, alternative = "two.sided", iseed=NULL, fix_i_in_Gstar_permutations=TRUE, no_repeat_in_row=FALSE) {
+localG_perm <- function(x, listw, nsim=499, zero.policy=attr(listw, "zero.policy"), spChk=NULL, alternative = "two.sided", iseed=NULL, fix_i_in_Gstar_permutations=TRUE, no_repeat_in_row=FALSE) {
     if (!inherits(listw, "listw"))
 	stop(paste(deparse(substitute(listw)), "is not a listw object"))
     if (!is.numeric(x))

diff --git a/R/listw2sn.R b/R/listw2sn.R
@@ -21,9 +21,17 @@ listw2sn <- function(listw) {
 	res
 }
 
-sn2listw <- function(sn) {
+sn2listw <- function(sn, style=NULL, zero.policy=NULL) {
 	if(!inherits(sn, "spatial.neighbour")) 
 	    stop("not a spatial.neighbour object")
+        if (is.null(zero.policy))
+            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+        stopifnot(is.logical(zero.policy))
+        if (is.null(style)) {
+            style <- "M"
+        }
+        if (style == "M")
+            warning("style is M (missing); style should be set to a valid value")
 	n <- attr(sn, "n")
 	if (n < 1) stop("non-positive n")
 	region.id <- attr(sn, "region.id")
@@ -55,12 +63,25 @@ sn2listw <- function(sn) {
 			nlist[[i]] <- 0L
 		}
 	}
-	res <- list(style=as.character(NA), neighbours=nlist, weights=vlist)
+	res <- list(style=style, neighbours=nlist, weights=vlist)
 	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
+            }
+        }
 	if (!(is.null(attr(sn, "GeoDa"))))
 		attr(res, "GeoDa") <- attr(sn, "GeoDa")
 	attr(res, "region.id") <- region.id
 	attr(res, "call") <- match.call()
+        attr(res, "zero.policy") <- zero.policy
+        if (style != "M") {
+	    if (!(style %in% c("W", "B", "C", "S", "U", "minmax")))
+		stop(paste("Style", style, "invalid"))
+            res <- nb2listw(res$neighbours, glist=res$weights, style=style,
+                zero.policy=zero.policy)
+        }
 	res
 }
 
diff --git a/R/lm.LMtests.R b/R/lm.LMtests.R
@@ -1,7 +1,7 @@
 # Copyright 2001-7 by Roger Bivand 
 #
 
-lm.LMtests <- function(model, listw, zero.policy=NULL, test="LMerr",
+lm.LMtests <- function(model, listw, zero.policy=attr(listw, "zero.policy"), test="LMerr",
 	spChk=NULL, naSubset=TRUE) {
 
 	if (inherits(model, "lm")) na.act <- model$na.action

diff --git a/R/lm.morantest.R b/R/lm.morantest.R
@@ -1,7 +1,7 @@
 # Copyright 2001-2010 by Roger Bivand 
 #
 
-lm.morantest <- function(model, listw, zero.policy=NULL, 
+lm.morantest <- function(model, listw, zero.policy=attr(listw, "zero.policy"), 
 	    alternative = "greater", spChk=NULL, resfun=weighted.residuals,		    naSubset=TRUE) {
         if (is.null(zero.policy))
             zero.policy <- get("zeroPolicy", envir = .spdepOptions)

diff --git a/R/localC.R b/R/localC.R
@@ -3,7 +3,7 @@ localC <- function(x, ..., zero.policy=NULL) {
 }
 
 
-localC.default <- function(x, listw, ..., zero.policy=NULL) {
+localC.default <- function(x, listw, ..., zero.policy=attr(listw, "zero.policy")) {
   # check listw object
   if (!inherits(listw, "listw"))
     stop(paste(deparse(substitute(listw)), "is not a listw object"))
@@ -14,7 +14,7 @@ localC.default <- function(x, listw, ..., zero.policy=NULL) {
   localC_calc(scale(x), listw, zero.policy=zero.policy)
 }
 
-localC.formula <- function(formula, data, listw, ..., zero.policy=NULL) {
+localC.formula <- function(formula, data, listw, ..., zero.policy=attr(listw, "zero.policy")) {
   # check listw object
   if (!inherits(listw, "listw"))
     stop(paste(deparse(substitute(listw)), "is not a listw object."))
@@ -44,7 +44,7 @@ localC.formula <- function(formula, data, listw, ..., zero.policy=NULL) {
 
 }
 
-localC.list <- function(x, listw, ..., zero.policy=NULL) {
+localC.list <- function(x, listw, ..., zero.policy=attr(listw, "zero.policy")) {
 
   if (!inherits(listw, "listw"))
     stop(paste(deparse(substitute(listw)), "is not a listw object,"))
@@ -59,7 +59,7 @@ localC.list <- function(x, listw, ..., zero.policy=NULL) {
 }
 
 
-localC.matrix <- function(x, listw, ..., zero.policy=NULL) {
+localC.matrix <- function(x, listw, ..., zero.policy=attr(listw, "zero.policy")) {
 
   if (!inherits(listw, "listw"))
     stop(paste(deparse(substitute(listw)), "is not a listw object"))
@@ -69,7 +69,7 @@ localC.matrix <- function(x, listw, ..., zero.policy=NULL) {
   rowSums(apply(scale(x), 2, localC_calc, listw, zero.policy=zero.policy)) / ncol(x)
 }
 
-localC.data.frame <- function(x, listw, ..., zero.policy=NULL) {
+localC.data.frame <- function(x, listw, ..., zero.policy=attr(listw, "zero.policy")) {
 
   if (inherits(x, "sf")) {
     x[[attr(x, "sf_column")]] <- NULL
@@ -90,7 +90,7 @@ localC_perm <- function(x, ..., zero.policy=NULL, iseed=NULL,
 }
 
 localC_perm.default <- function(x, listw, nsim = 499, alternative = "two.sided",
-             ..., zero.policy=NULL, iseed=NULL, no_repeat_in_row=FALSE) {
+             ..., zero.policy=attr(listw, "zero.policy"), iseed=NULL, no_repeat_in_row=FALSE) {
 
   alternative <- match.arg(alternative, c("two.sided", "less", "greater"))
   # checks are inherited from localC no need to implement
@@ -151,7 +151,7 @@ localC_perm.default <- function(x, listw, nsim = 499, alternative = "two.sided",
 
 localC_perm.formula <- function(formula, data, listw,
                                 nsim = 499, alternative = "two.sided", ...,
-                                zero.policy=NULL, iseed=NULL, 
+                                zero.policy=attr(listw, "zero.policy"), iseed=NULL, 
                                 no_repeat_in_row=FALSE) {
 
   alternative <- match.arg(alternative, c("less", "two.sided", "greater"))
@@ -200,7 +200,7 @@ localC_perm.formula <- function(formula, data, listw,
 # "localC" cluster nlevel==4L (uni) c("High-High", "Low-Low", "Other Positive", "Negative")
 
 # Local Geary Utils -------------------------------------------------------
-localC_calc <- function(x, listw, zero.policy=NULL) {
+localC_calc <- function(x, listw, zero.policy=attr(listw, "zero.policy")) {
   if (any(card(listw$neighbours) == 0L)) {
     res <- geary.intern(x, listw, n=length(listw$neighbours), zero.policy=zero.policy)
   } else {
@@ -215,7 +215,7 @@ localC_calc <- function(x, listw, zero.policy=NULL) {
 }
 
 localC_perm_calc <- function(x, listw, obs, nsim, alternative="two.sided",
-  zero.policy=NULL, iseed=NULL, no_repeat_in_row=FALSE) {
+  zero.policy=attr(listw, "zero.policy"), iseed=NULL, no_repeat_in_row=FALSE) {
     nc <- ncol(x)
     stopifnot(nc > 0L)
     n <- length(listw$neighbours)

diff --git a/R/localG.R b/R/localG.R
@@ -1,7 +1,7 @@
 # Copyright 2001-18 by Roger Bivand 
 #
 
-localG <- function(x, listw, zero.policy=NULL, spChk=NULL, GeoDa=FALSE, alternative = "two.sided", return_internals=TRUE) {
+localG <- function(x, listw, zero.policy=attr(listw, "zero.policy"), spChk=NULL, GeoDa=FALSE, alternative = "two.sided", return_internals=TRUE) {
 	if (!inherits(listw, "listw"))
 		stop(paste(deparse(substitute(listw)), "is not a listw object"))
 	if (!is.numeric(x))

diff --git a/R/localmoran.R b/R/localmoran.R
@@ -1,7 +1,7 @@
 # Copyright 2001-18 by Roger Bivand, 2021 Jeff Sauer and Levi Wolf (conditional code)
 #
 
-localmoran <- function(x, listw, zero.policy=NULL, na.action=na.fail,
+localmoran <- function(x, listw, zero.policy=attr(listw, "zero.policy"), na.action=na.fail,
         conditional=TRUE, alternative = "two.sided",
         mlvar=TRUE, spChk=NULL, adjust.x=FALSE) {
         stopifnot(is.vector(x))