add local options to subgraphs vignette

R/AAA.R

@@ -1,10 +1,9 @@
-# Copyright 2001-15 by Roger Bivand 
+# Copyright 2001-24 by Roger Bivand 
 #
 
-.spdepOptions <- new.env(FALSE, globalenv())
+.spdepOptions <- new.env(TRUE, 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/EBI.R

@@ -6,7 +6,7 @@ EBImoran <- function (z, listw, nn, S0, zero.policy = attr(listw, "zero.policy")
 {
 #default subtract_mean_in_numerator=TRUE 160219 RA
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
     stopifnot(is.vector(z))
     zm <- mean(z)
@@ -24,7 +24,7 @@ EBImoran.mc <- function (n, x, listw, nsim, zero.policy = attr(listw, "zero.poli
 #default subtract_mean_in_numerator=TRUE 160219 RA
     message("The default for subtract_mean_in_numerator set TRUE from February 2016")
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
     alternative <- match.arg(alternative, c("greater", "less", "two.sided"))
     if (!inherits(listw, "listw")) 
@@ -198,7 +198,7 @@ EBest <- function(n, x, family="poisson") {
 EBlocal <- function(ri, ni, nb, zero.policy = NULL,
     spChk = NULL, geoda = FALSE) {
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 # class to inherits Jari Oksanen 080603
     if (!inherits(nb, "nb")) 

R/LOSH.R

@@ -1,6 +1,6 @@
 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)
+    zero.policy <- get.ZeroPolicyOption()
   stopifnot(is.logical(zero.policy))
   n <- length(listw$neighbours)
   #a <- 2    ## "a" could be any other positive value, but the chi-square-based inference is then no longer possible

R/LOSH.cs.R

@@ -5,7 +5,7 @@ LOSH.cs <- function(x, listw, zero.policy = attr(listw, "zero.policy"), na.actio
   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)
+    zero.policy <- get.ZeroPolicyOption()
   stopifnot(is.logical(zero.policy))
   if (!is.null(attr(listw$neighbours, "self.included")) && 
       attr(listw$neighbours, "self.included")) 

R/LOSH.mc.R

@@ -5,7 +5,7 @@ LOSH.mc <- function(x, listw, a = 2, nsim = 99, zero.policy = attr(listw, "zero.
   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)
+    zero.policy <- get.ZeroPolicyOption()
   stopifnot(is.logical(zero.policy))
   if (!is.null(attr(listw$neighbours, "self.included")) && 
       attr(listw$neighbours, "self.included")) 

R/SD.RStests.R

@@ -88,7 +88,7 @@ SD.RStests <- function(model, listw, zero.policy=attr(listw, "zero.policy"), tes
 	if (!inherits(listw, "listw")) stop(paste(listw_name,
 		"is not a listw object"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	if (!is.null(na.act)) {
 	    subset <- !(1:length(listw$neighbours) %in% na.act)

R/autocov.R

@@ -18,7 +18,7 @@
 autocov_dist <- function(z, xy, nbs=1, type="inverse", zero.policy=NULL,
    style="B", longlat=NULL) {
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
     stopifnot(is.vector(z))
    if (type=="one") expo <- 0

R/diffnb.R

@@ -5,7 +5,7 @@
 diffnb <- function(x, y, verbose=NULL) {
 	if (!inherits(x, "nb")) stop("not a neighbours list")
 	if (!inherits(y, "nb")) stop("not a neighbours list")
-        if (is.null(verbose)) verbose <- get("verbose", envir = .spdepOptions)
+        if (is.null(verbose)) verbose <- get.VerboseOption()
         stopifnot(is.logical(verbose))
 	n <- length(x)
 	if (n < 1) stop("non-positive length of x")

R/geary.R

@@ -5,7 +5,7 @@
 geary <- function(x, listw, n, n1, S0, zero.policy=attr(listw, "zero.policy"),
         scale=TRUE) { #https://github.com/r-spatial/spdep/issues/151
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
         stopifnot(is.vector(x))
         stopifnot(all(is.finite(x)))
@@ -21,7 +21,7 @@ geary <- function(x, listw, n, n1, S0, zero.policy=attr(listw, "zero.policy"),
 
 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)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	cardnb <- card(listw$neighbours)
 	if (type == "geary") ft <- TRUE
@@ -39,7 +39,7 @@ geary.test <- function(x, listw, randomisation=TRUE,
     spChk=NULL, adjust.n=TRUE, na.action=na.fail, scale=TRUE) { 
 #https://github.com/r-spatial/spdep/issues/151
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	alternative <- match.arg(alternative, c("less", "greater", "two.sided"))
 	wname <- deparse(substitute(listw))
@@ -115,7 +115,7 @@ geary.mc <- function(x, listw, nsim, zero.policy=attr(listw, "zero.policy"),
 	alternative="greater", spChk=NULL, adjust.n=TRUE, return_boot=FALSE,
         na.action=na.fail, scale=TRUE) {
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
         stopifnot(is.vector(x))
 	alternative <- match.arg(alternative, c("less", "greater", "two.sided"))

R/globalG.R

@@ -7,7 +7,7 @@ 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, na.action=na.fail) {
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
         stopifnot(is.vector(x))
 	alternative <- match.arg(alternative, c("greater", "less", "two.sided"))

R/jc.R

@@ -18,7 +18,7 @@ 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))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	alternative <- match.arg(alternative, c("greater", "less", "two.sided"))
 	sampling <- match.arg(sampling, c("nonfree", "free"))
@@ -113,7 +113,7 @@ joincount.mc <- function(fx, listw, nsim, zero.policy=attr(listw, "zero.policy")
 	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)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	if(!is.factor(fx)) stop(paste(deparse(substitute(fx)),
 		"is not a factor"))
@@ -192,7 +192,7 @@ joincount.multi <- function(fx, listw, zero.policy=attr(listw, "zero.policy"), #
 		"is not a factor"))
 	if (any(is.na(fx))) stop("NA in factor")
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	n <- length(listw$neighbours)
 	if (n != length(fx)) stop("objects of different length")

R/lee.R

@@ -3,7 +3,7 @@
 
 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)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
         n1 <- length(listw$neighbours)
         x <- c(x)

R/lee.mc.R

@@ -11,7 +11,7 @@ lee.mc <- function(x, y, listw, nsim, zero.policy=attr(listw, "zero.policy"),
 	if(!is.numeric(x) | !is.numeric(y)) stop(paste(deparse(substitute(x)),
 		"is not a numeric vector"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	if(missing(nsim)) stop("nsim must be given")
 	if (is.null(spChk)) spChk <- get.spChkOption()

R/lee.test.R

@@ -16,7 +16,7 @@ lee.test <- function(x, y, listw, #randomisation=TRUE,
 	if (!is.numeric(y)) stop(paste(deparse(substitute(y)),
 		"is not a numeric vector"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	if (is.null(spChk)) spChk <- get.spChkOption()
 	if (spChk && !chkIDs(x, listw) && !chkIDs(y, listw))

R/licd_boots.R

@@ -13,7 +13,7 @@ licd_multi <- function(fx, listw, zero.policy=attr(listw, "zero.policy"),
         "is not a factor"))
     if (any(is.na(fx))) stop("NA in factor")
     if (is.null(zero.policy))
-        zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+        zero.policy <- get.ZeroPolicyOption()
     stopifnot(is.logical(zero.policy))
     n <- length(listw$neighbours)
     if (n != length(fx)) stop("objects of different length")

R/lisa_perm.R

@@ -94,7 +94,7 @@ localmoran_perm <- function(x, listw, nsim=499L, zero.policy=attr(listw, "zero.p
     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)
+        zero.policy <- get.ZeroPolicyOption()
     stopifnot(is.logical(zero.policy))
     if (!is.null(attr(listw$neighbours, "self.included")) &&
 	attr(listw$neighbours, "self.included"))
@@ -259,7 +259,7 @@ localG_perm <- function(x, listw, nsim=499, zero.policy=attr(listw, "zero.policy
     if (!is.numeric(x))
 	stop(paste(deparse(substitute(x)), "is not a numeric vector"))
     if (is.null(zero.policy))
-        zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+        zero.policy <- get.ZeroPolicyOption()
     stopifnot(is.logical(zero.policy))
     stopifnot(is.vector(x))
     if (any(is.na(x))) stop(paste("NA in ", deparse(substitute(x))))

R/listw2sn.R

@@ -25,7 +25,7 @@ sn2listw <- function(sn, style=NULL, zero.policy=NULL, from_mat2listw=FALSE) {
 	if(!inherits(sn, "spatial.neighbour")) 
 	    stop("not a spatial.neighbour object")
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
         if (is.null(style)) {
             style <- "M"

R/lm.RStests.R

@@ -17,7 +17,7 @@ lm.RStests <- function(model, listw, zero.policy=attr(listw, "zero.policy"), tes
 	if (!inherits(listw, "listw")) stop(paste(listw_name,
 		"is not a listw object"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	if (!is.null(na.act) && naSubset) {
 	    subset <- !(1:length(listw$neighbours) %in% na.act)

R/lm.morantest.R

@@ -4,7 +4,7 @@
 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)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	alternative <- match.arg(alternative, c("greater", "less", "two.sided"))
 	listw_name <- deparse(substitute(listw))

R/local-moran-bv.R

@@ -12,7 +12,7 @@ localmoran_bv <- function(x, y, listw, nsim = 199, scale = TRUE,
   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)
+    zero.policy <- get.ZeroPolicyOption()
   stopifnot(is.logical(zero.policy))
   n <- length(listw$neighbours)
   if (n != length(x)) stop("Different numbers of observations")

R/localG.R

@@ -7,7 +7,7 @@ localG <- function(x, listw, zero.policy=attr(listw, "zero.policy"), spChk=NULL,
 	if (!is.numeric(x))
 		stop(paste(deparse(substitute(x)), "is not a numeric vector"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
         stopifnot(is.vector(x))
 	if (any(is.na(x))) stop(paste("NA in ", deparse(substitute(x))))

R/localmoran.R

@@ -8,7 +8,7 @@ localmoran <- function(x, listw, zero.policy=attr(listw, "zero.policy"), na.acti
 	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)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
         alternative <- match.arg(alternative, c("two.sided", "greater", "less"))
 	if (!is.null(attr(listw$neighbours, "self.included")) &&

R/localmoran.exact.R

@@ -9,7 +9,7 @@ localmoran.exact <- function(model, select, nb, glist = NULL, style = "W",
   if (!inherits(nb, "nb"))
         stop(paste(deparse(substitute(nb)), "not an nb object"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
     n <- length(nb)
     u <- resfun(model)

R/moran.R

@@ -3,7 +3,7 @@
 
 moran <- function(x, listw, n, S0, zero.policy=attr(listw, "zero.policy"), NAOK=FALSE) {
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	n1 <- length(listw$neighbours)
 	x <- c(x)
@@ -28,7 +28,7 @@ moran.test <- function(x, listw, randomisation=TRUE, zero.policy=attr(listw, "ze
 	xname <- deparse(substitute(x))
 	if (!is.numeric(x)) stop(xname,	" is not a numeric vector")
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	if (is.null(spChk)) spChk <- get.spChkOption()
 	if (spChk && !chkIDs(x, listw))
@@ -102,7 +102,7 @@ moran.mc <- function(x, listw, nsim, zero.policy=attr(listw, "zero.policy"),
 	xname <- deparse(substitute(x))
 	if(!is.numeric(x)) stop(xname, "is not a numeric vector")
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	if(missing(nsim)) stop("nsim must be given")
 	if (is.null(spChk)) spChk <- get.spChkOption()

R/moran.exact.R

@@ -10,7 +10,7 @@ lm.morantest.exact <- function(model, listw, zero.policy = attr(listw, "zero.pol
     if (!inherits(model, "lm")) 
         stop(paste(deparse(substitute(model)), "not an lm object"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
     N <- length(listw$neighbours)
     u <- resfun(model)

R/moran.exact.alt.R

@@ -8,9 +8,9 @@ localmoran.exact.alt <- function(model, select, nb, glist = NULL, style = "W",
 # class to inherits Jari Oksanen 080603
     if (!inherits(nb, "nb"))
         stop(paste(deparse(substitute(nb)), "not an nb object"))
-        if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
-        stopifnot(is.logical(zero.policy))
+    if (is.null(zero.policy))
+        zero.policy <- get.ZeroPolicyOption()
+    stopifnot(is.logical(zero.policy))
 #    if (class(model) != "lm") 
 #        stop(paste(deparse(substitute(model)), "not an lm object"))
     dmc <- deparse(model$call)

R/moran.plot.R

@@ -6,12 +6,12 @@ moran.plot <- function(x, listw, y=NULL, zero.policy=attr(listw, "zero.policy"),
 {
 	if (!inherits(listw, "listw")) stop(paste(deparse(substitute(listw)),
 		"is not a listw object"))
-        if (is.null(quiet)) quiet <- !get("verbose", envir = .spdepOptions)
+        if (is.null(quiet)) quiet <- !get.VerboseOption()
         stopifnot(is.vector(x))
         if (!is.null(y)) stopifnot(is.vector(y))
         stopifnot(is.logical(quiet))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
 	xname <- deparse(substitute(x))
 	if (!is.numeric(x)) stop(paste(xname, "is not a numeric vector"))

R/mtlocalmoran.R

@@ -12,7 +12,7 @@ localmoran.sad <- function (model, select, nb, glist = NULL, style = "W",
     if (!inherits(nb, "nb"))
         stop(paste(deparse(substitute(nb)), "not an nb object"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
     n <- length(nb)
     dmc <- deparse(model$call)

R/mtmoran.R

@@ -11,7 +11,7 @@ lm.morantest.sad <- function (model, listw, zero.policy = attr(listw, "zero.poli
     if (!inherits(model, "lm")) 
         stop(paste(deparse(substitute(model)), "not an lm object"))
         if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+            zero.policy <- get.ZeroPolicyOption()
         stopifnot(is.logical(zero.policy))
     N <- length(listw$neighbours)
     u <- resfun(model)

R/nb2listw.R

@@ -4,16 +4,16 @@
 nb2listw <- function(neighbours, glist=NULL, style="W", zero.policy=NULL)
 {
 	if(!inherits(neighbours, "nb")) stop("Not a neighbours list")
-        if (is.null(zero.policy))
-            zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+        if (is.null(zero.policy)) {
+            zero.policy <- get.ZeroPolicyOption()
+        }
         stopifnot(is.logical(zero.policy))
 	if (!(style %in% c("W", "B", "C", "S", "U", "minmax")))
 		stop(paste("Style", style, "invalid"))
 	n <- length(neighbours)
 	if (n < 1) stop("non-positive number of entities")
 	cardnb <- card(neighbours)
-	if (!zero.policy)
-		if (any(cardnb == 0)) stop("Empty neighbour sets found")
+	if (!zero.policy && any(cardnb == 0)) stop("Empty neighbour sets found (zero.policy: ", zero.policy, ")")
 	vlist <- vector(mode="list", length=n)
 	if (is.null(glist)) {
 		glist <- vector(mode="list", length=n)

R/nb2listwdist.R

@@ -2,7 +2,7 @@ nb2listwdist <- function(neighbours, x, type="idw", style="raw", alpha = 1, dmax
 {
   if(!inherits(neighbours, "nb")) stop("Not a neighbours list")
   if (is.null(zero.policy))
-    zero.policy <- get("zeroPolicy", envir = .spdepOptions)
+    zero.policy <- get.ZeroPolicyOption()
   stopifnot(is.logical(zero.policy))
   if (!(type %in% c("idw", "dpd", "exp")))
     stop(paste("type", type, "invalid"))