diff --git a/R/AAA.R b/R/AAA.R index 622923a6..a0f665b3 100644 --- a/R/AAA.R +++ b/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) diff --git a/R/EBI.R b/R/EBI.R index 05050d0f..7eb7c6f7 100644 --- a/R/EBI.R +++ b/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")) diff --git a/R/LOSH.R b/R/LOSH.R index 85a9f81d..50e7c01a 100644 --- a/R/LOSH.R +++ b/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 diff --git a/R/LOSH.cs.R b/R/LOSH.cs.R index 6d49b207..e3389530 100644 --- a/R/LOSH.cs.R +++ b/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")) diff --git a/R/LOSH.mc.R b/R/LOSH.mc.R index aa854a14..397051bb 100644 --- a/R/LOSH.mc.R +++ b/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")) diff --git a/R/SD.RStests.R b/R/SD.RStests.R index 498d85c0..c91ea6ff 100644 --- a/R/SD.RStests.R +++ b/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) diff --git a/R/autocov.R b/R/autocov.R index a5aa7dfd..212a3874 100644 --- a/R/autocov.R +++ b/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 diff --git a/R/diffnb.R b/R/diffnb.R index 57174613..7c1c027f 100644 --- a/R/diffnb.R +++ b/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") diff --git a/R/geary.R b/R/geary.R index d60a2979..3a715b2b 100644 --- a/R/geary.R +++ b/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")) diff --git a/R/globalG.R b/R/globalG.R index 7fc442f5..849fc147 100644 --- a/R/globalG.R +++ b/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")) diff --git a/R/jc.R b/R/jc.R index ecb6b822..8b2842c5 100644 --- a/R/jc.R +++ b/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") diff --git a/R/lee.R b/R/lee.R index 35a8c0ca..0d7ed1ee 100644 --- a/R/lee.R +++ b/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) diff --git a/R/lee.mc.R b/R/lee.mc.R index 23fa2758..8e555178 100644 --- a/R/lee.mc.R +++ b/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() diff --git a/R/lee.test.R b/R/lee.test.R index a0429e7a..f90d28b3 100644 --- a/R/lee.test.R +++ b/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)) diff --git a/R/licd_boots.R b/R/licd_boots.R index d0fe98a5..24074c1c 100644 --- a/R/licd_boots.R +++ b/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") diff --git a/R/lisa_perm.R b/R/lisa_perm.R index e4e7605a..304b358c 100644 --- a/R/lisa_perm.R +++ b/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)))) diff --git a/R/listw2sn.R b/R/listw2sn.R index 5db7ff49..5ae0e3ee 100644 --- a/R/listw2sn.R +++ b/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" diff --git a/R/lm.RStests.R b/R/lm.RStests.R index 6f77bc4e..15ec81f8 100644 --- a/R/lm.RStests.R +++ b/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) diff --git a/R/lm.morantest.R b/R/lm.morantest.R index c18ee122..1116016f 100644 --- a/R/lm.morantest.R +++ b/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)) diff --git a/R/local-moran-bv.R b/R/local-moran-bv.R index 6fd681b3..a0559643 100644 --- a/R/local-moran-bv.R +++ b/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") diff --git a/R/localG.R b/R/localG.R index 5f333a0b..4c52302e 100644 --- a/R/localG.R +++ b/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)))) diff --git a/R/localmoran.R b/R/localmoran.R index 009c700d..534a0f45 100644 --- a/R/localmoran.R +++ b/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")) && diff --git a/R/localmoran.exact.R b/R/localmoran.exact.R index 85751700..31e986ff 100644 --- a/R/localmoran.exact.R +++ b/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) diff --git a/R/moran.R b/R/moran.R index ef8c3f39..52c44374 100644 --- a/R/moran.R +++ b/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() diff --git a/R/moran.exact.R b/R/moran.exact.R index 0dbd5741..ed010d7e 100644 --- a/R/moran.exact.R +++ b/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) diff --git a/R/moran.exact.alt.R b/R/moran.exact.alt.R index 746abb31..ef14aee2 100644 --- a/R/moran.exact.alt.R +++ b/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) diff --git a/R/moran.plot.R b/R/moran.plot.R index 80a1e447..6891afa3 100644 --- a/R/moran.plot.R +++ b/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")) diff --git a/R/mtlocalmoran.R b/R/mtlocalmoran.R index bbfd9556..ad399f77 100644 --- a/R/mtlocalmoran.R +++ b/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) diff --git a/R/mtmoran.R b/R/mtmoran.R index 4435ebc6..4055e023 100644 --- a/R/mtmoran.R +++ b/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) diff --git a/R/nb2listw.R b/R/nb2listw.R index a94c5d2e..6e0926ce 100644 --- a/R/nb2listw.R +++ b/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) diff --git a/R/nb2listwdist.R b/R/nb2listwdist.R index 8e1ce7ad..2e7d72a7 100644 --- a/R/nb2listwdist.R +++ b/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")) diff --git a/R/nb2mat.R b/R/nb2mat.R index 64b46868..f8af0043 100644 --- a/R/nb2mat.R +++ b/R/nb2mat.R @@ -5,7 +5,7 @@ nb2mat <- function(neighbours, glist=NULL, style="W", zero.policy=NULL) { if (is.null(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() stopifnot(is.logical(zero.policy)) if(!inherits(neighbours, "nb")) stop("Not a neighbours list") listw <- nb2listw(neighbours, glist=glist, style=style, @@ -40,7 +40,7 @@ mat2listw <- function(x, row.names=NULL, style=NULL, zero.policy=NULL) { 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(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() if (!is.null(row.names)) { if(length(row.names) != n) stop("row.names wrong length") diff --git a/R/poly2nb.R b/R/poly2nb.R index 619f4a7e..b05456b9 100644 --- a/R/poly2nb.R +++ b/R/poly2nb.R @@ -7,7 +7,7 @@ poly2nb <- function(pl, row.names=NULL, snap=NULL, queen=TRUE, useC=TRUE, foundInBox=NULL) { - verbose <- get("verbose", envir = .spdepOptions) + verbose <- get.VerboseOption() .ptime_start <- proc.time() sf <- NULL if (extends(class(pl), "SpatialPolygons")) { diff --git a/R/sp.correlogram.R b/R/sp.correlogram.R index 48c252d8..d58ece0a 100644 --- a/R/sp.correlogram.R +++ b/R/sp.correlogram.R @@ -9,7 +9,7 @@ sp.correlogram <- function (neighbours, var, order = 1, method = "corr", if (any(is.na(var))) stop("no NAs permitted in variable") 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() diff --git a/R/sp.mantel.R b/R/sp.mantel.R index 0f813d58..84b152b5 100644 --- a/R/sp.mantel.R +++ b/R/sp.mantel.R @@ -5,7 +5,7 @@ sp.mantel.mc <- function(var, listw, nsim, type="moran", zero.policy=attr(listw, "zero.policy"), alternative="greater", spChk=NULL, return_boot=FALSE) { if (is.null(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() stopifnot(is.logical(zero.policy)) stopifnot(is.vector(var)) alternative <- match.arg(alternative, c("greater", "less", "two.sided")) diff --git a/R/spChkOption.R b/R/spChkOption.R index 8d1e4c2e..121ac81a 100644 --- a/R/spChkOption.R +++ b/R/spChkOption.R @@ -69,7 +69,7 @@ get.VerboseOption <- function() { set.ZeroPolicyOption <- function(check) { if (!is.logical(check)) stop ("logical argument required") - res <- get("zeroPolicy", envir = .spdepOptions) + res <- get.ZeroPolicyOption() assign("zeroPolicy", check, envir = .spdepOptions) invisible(res) } diff --git a/R/subset.nb.R b/R/subset.nb.R index 9c523333..49f5554e 100644 --- a/R/subset.nb.R +++ b/R/subset.nb.R @@ -53,7 +53,7 @@ subset.nb <- function(x, subset, ...) { subset.listw <- function(x, subset, zero.policy=attr(x, "zero.policy"), ...) { if (!inherits(x, "listw")) stop("not a weights list") if (is.null(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() stopifnot(is.logical(zero.policy)) if (!is.logical(subset)) stop("subset not a logical vector") nb <- x$neighbours diff --git a/R/summary.nb.R b/R/summary.nb.R index 41a55e19..c557bd57 100644 --- a/R/summary.nb.R +++ b/R/summary.nb.R @@ -80,7 +80,7 @@ print.nb <- function(x, ...) { summary.listw <- function(object, coords=NULL, longlat=FALSE, zero.policy=attr(object, "zero.policy"), scale=1, adjust.n=TRUE, ...) { if (is.null(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() stopifnot(is.logical(zero.policy)) if (any(card(object$neighbours) == 0) && !zero.policy) stop("regions with no neighbours found, use zero.policy=TRUE") @@ -106,7 +106,7 @@ print.summary.listw <- function(x, ...) { print.listw <- function(x, zero.policy=attr(x, "zero.policy"), ...) { if (is.null(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() stopifnot(is.logical(zero.policy)) if (any(card(x$neighbours) == 0) && !zero.policy) stop("regions with no neighbours found, use zero.policy=TRUE") diff --git a/R/utils.R b/R/utils.R index 6bd7866c..ea38c4cd 100644 --- a/R/utils.R +++ b/R/utils.R @@ -19,7 +19,7 @@ spweights.constants <- function(listw, zero.policy=attr(listw, "zero.policy"), a "is not a listw object")) cards <- card(listw$neighbours) if (is.null(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() stopifnot(is.logical(zero.policy)) if (!zero.policy && any(cards == 0)) stop("regions with no neighbours found") @@ -74,7 +74,7 @@ lag.listw <- function(x, var, zero.policy=attr(listw, "zero.policy"), NAOK=FALSE } else { listw <- x if (is.null(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() stopifnot(is.logical(zero.policy)) if (!inherits(listw, "listw")) stop(paste(deparse(substitute(x)), "is not a listw object")) @@ -177,7 +177,7 @@ listw2U <- function(listw) { listw2star <- function(listw, ireg, style, n, D, a, zero.policy=attr(listw, "zero.policy")) { if (is.null(zero.policy)) - zero.policy <- get("zeroPolicy", envir = .spdepOptions) + zero.policy <- get.ZeroPolicyOption() stopifnot(is.logical(zero.policy)) nb <- vector(mode="list", length=n) class(nb) <- "nb" diff --git a/R/weights-utils.R b/R/weights-utils.R index e09f48ca..cfba7e7f 100644 --- a/R/weights-utils.R +++ b/R/weights-utils.R @@ -5,7 +5,7 @@ is.symmetric.nb <- function(nb, verbose=NULL, force=FALSE) { if(!inherits(nb, "nb")) stop("Not neighbours list") - if (is.null(verbose)) verbose <- get("verbose", envir = .spdepOptions) + if (is.null(verbose)) verbose <- get.VerboseOption() stopifnot(is.logical(verbose)) nbsym <- attr(nb, "sym") if(!is.null(nbsym)) res <- nbsym diff --git a/vignettes/subgraphs.Rmd b/vignettes/subgraphs.Rmd index b3519708..57a5ccb5 100644 --- a/vignettes/subgraphs.Rmd +++ b/vignettes/subgraphs.Rmd @@ -96,7 +96,7 @@ plot(st_geometry(w50m), border="grey75") plot(nb_W_50m_snap, pts, add=TRUE) ``` -In this case, increasing `snap` from its default of 10mm (or close equivalents for geometries with known metrics; previously `sqrt(.Machine$double.eps)` `r print(sqrt(.Machine$double.eps))` in all cases) helps. The symmetric links added are to: +In this case, increasing `snap` from its default of 10mm (or close equivalents for geometries with known metrics; previously `sqrt(.Machine$double.eps)` `r sqrt(.Machine$double.eps)` in all cases) helps. The symmetric links added are to: ```{r, eval=run} attr(nb_W_50m_snap, "region.id")[nb_W_50m_snap[[which(ynys_mon)]]] @@ -260,9 +260,97 @@ plot(nb_sc_50m_iow, pts, add=TRUE) It remains to add a suitable generalisation of `addlinks1` to handle a `from` vector argument and a `to` argument taking a list of vectors. +## Per-session control of function behaviour + +From very early on, the default value of the `zero.policy` argument to many methods and functions was `NULL`. If the value was `NULL`, `zero.policy` would be set from `get.ZeroPolicyOption`: + +```{r, eval=run} +get.ZeroPolicyOption() +``` + +On loading `spdep`, the internal option is set to `FALSE`, so functions and methods using `zero.policy` need to choose how to handle islands: + + +```{r, eval=run} +try(nb2listw(nb_W_50m)) +``` +In this case, it was shown above how the island may reasonably be associated with proximate constituencies on the mainland. If, however, the user wishes to override the default, `set.ZeroPolicyOption` may be used to set a different per-session default: + + +```{r, eval=run} +set.ZeroPolicyOption(TRUE) +``` + +```{r, eval=run} +get.ZeroPolicyOption() +``` + +```{r, eval=FALSE, echo=TRUE} +(lw <- nb2listw(nb_W_50m)) +``` + +```{r, eval=run, echo=FALSE} +# repeated to overcome CMD build latency +(lw <- nb2listw(nb_W_50m, zero.policy=get.ZeroPolicyOption())) +``` + +```{r, eval=run} +attr(lw, "zero.policy") +``` + +```{r, eval=run} +set.ZeroPolicyOption(FALSE) +``` +When a `listw` object is created with `zero.policy` set to `TRUE`, this choice is added to the output object as an attribute and applied when the object is used (unless specifically overridden). Note also above that while there are 32 constituencies, the observation count reported by `spweights.constants` called by the `print` method for `listw` object has argument `adjust.n` TRUE, dropping no-neighbour observations from the observation count. + +Other internal options have been introduced to suppress no-neighbour and subgraph warnings. The default values are as follows: + +```{r, eval=run} +get.NoNeighbourOption() +get.SubgraphOption() +get.SubgraphCeiling() +``` +`get.NoNeighbourOption` controls the issuing of warnings when `nb` objects are created with no-neighbour observations; `get.SubgraphOption` works similarly but for warnings issued when there is more than one graph component; both are TRUE by default. `get.SubgraphCeiling` sets the integer value of graph nodes plus graph edges above which calculating on the graph is considered too costly in compute time, the default is 100,000. This corresponds to a dense neighbour set with just over 300 nodes (with almost 100000 edges) such as that needed to use inverse distance weights, or just over 14,000 nodes with an average neighbour count of 6. + +The `print` method for `nb` objects reports no-neighbour and subgraph status anyway, so careful users who always examine generated objects may prefer to supress the warnings, but warnings seem prudent when users may not examine the objects, or when generation is by subsetting of larger objects, for example in the creation of training and test data sets. Here the Welsh constituency boundaries will be used to show the behaviour of the internal options: + +```{r, eval=run} +set.NoNeighbourOption(FALSE) +(w50m |> poly2nb(row.names=as.character(w50m$Constituency)) -> nb_W_50mz) +``` +Turning both off removes the warnings: + +```{r, eval=run} +set.SubgraphOption(FALSE) +(w50m |> poly2nb(row.names=as.character(w50m$Constituency)) -> nb_W_50my) +``` +When `get.SubgraphOption` is FALSE, the attribute containing the output of `n.comp.nb` is not added: + +```{r, eval=run} +str(attr(nb_W_50my, "ncomp")) +``` + +The reduction of the ceiling to below node count `r length(nb_W_50m)` plus edge count `r sum(card(nb_W_50m))` also supresses the calculation of graph components: + +```{r, eval=run} +set.SubgraphOption(TRUE) +set.SubgraphCeiling(100L) +(w50m |> poly2nb(row.names=as.character(w50m$Constituency)) -> nb_W_50mx) +``` + +```{r, eval=run} +str(attr(nb_W_50mx, "ncomp")) +``` +Restoring the remaining default values: + +```{r, eval=run} +set.SubgraphCeiling(100000L) +set.NoNeighbourOption(TRUE) +``` + ## Unintentional disconnected graphs -Sometimes apparently sensible polygons turn out to be represented in such a way that disconnected graphs are generated when extracting contiguities. One such case was raised in https://github.com/r-spatial/spdep/issues/162, for subdivisions of Tokyo. +Sometimes apparently sensible polygons turn out to be represented in such a way that disconnected graphs are generated when extracting contiguities. One such case was raised in https://github.com/r-spatial/spdep/issues/162, for subdivisions of Tokyo. The original data file `tokyomet262.*` from https://sgsup.asu.edu/sites/default/files/SparcFiles/tokyo_0.zip was created some twenty years ago by Tomoki Nakaya and Martin Charlton, and some geometry issues were known at the time. A possibility that may affect legacy files is projection of geometries on 32-bit platforms, but it is not known whether this affected this file. Here it has been re-packaged as a compressed GeoPackage: ```{r, eval=run} tokyo <- st_read(system.file("etc/shapes/tokyo.gpkg.zip", package="spdep"))