Merge pull request #166 from r-spatial/swm_dbf

Swm dbf #163

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: spdep
 Version: 1.3-6
-Date: 2024-08-02
+Date: 2024-08-13
 Title: Spatial Dependence: Weighting Schemes, Statistics
 Encoding: UTF-8
 Authors@R: c(person("Roger", "Bivand", role = c("cre", "aut"), 

NAMESPACE

@@ -39,8 +39,9 @@ export(gabrielneigh, geary.test, geary, geary.mc, globalG.test, graph2nb,
 	joincount.test, joincount.mc, joincount.multi, print.jcmulti,
 	knearneigh, knn2nb)
 
-export(listw2sn, sn2listw, read.gwt2nb,	write.sn2gwt, lm.LMtests, 
-        lm.RStests, SD.RStests,
+export(listw2sn, sn2listw, read.gwt2nb,	write.sn2gwt,
+        read.swmdbf2listw, read_swm_dbf, write.sn2DBF,
+        lm.LMtests, lm.RStests, SD.RStests,
 	lm.morantest, localG, localG_perm, localmoran, localmoran_perm, moran,
 	moran.test, moran.mc, moran.plot, localmoran.sad, lm.morantest.sad,
 	nb2listw, nb2listwdist, nb2mat, listw2mat, mat2listw, nbdists, nblag,

R/listw2sn.R

@@ -74,6 +74,14 @@ sn2listw <- function(sn, style=NULL, zero.policy=NULL, from_mat2listw=FALSE) {
                 warning("no-neighbour observations found, set zero.policy to TRUE;\nthis warning will soon become an error")
             }
         }
+	attr(res$neighbours, "region.id") <- region.id
+	res$neighbours <- sym.attr.nb(res$neighbours)
+        NE <- n + sum(card(res$neighbours))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+          ncomp <- n.comp.nb(res$neighbours)
+          attr(res$neighbours, "ncomp") <- ncomp
+          if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
+        }
 	if (!(is.null(attr(sn, "GeoDa"))))
 		attr(res, "GeoDa") <- attr(sn, "GeoDa")
 	attr(res, "region.id") <- region.id

R/read.gwt2nb.R

@@ -156,6 +156,21 @@ write.sn2Arc <- function(sn, file, field=NULL) {
 	close(con)
 }
 
+write.sn2DBF <- function(sn, file) {
+	if(!inherits(sn, "spatial.neighbour")) 
+	    stop("not a spatial.neighbour object")
+	n <- attr(sn, "n")
+	if (n < 1) stop("non-positive number of entities")
+	nms <- as.character(attr(sn, "region.id"))
+	sn[,1] <- as.integer(nms[sn[,1]])
+	sn[,2] <- as.integer(nms[sn[,2]])
+        sn <- cbind(data.frame(Field1=rep(0L, nrow(sn))), sn)
+        if (requireNamespace("foreign", quietly=TRUE)) {
+           foreign::write.dbf(sn, file)
+        } else warning("foreign::read.dbf not available")
+        invisible(sn)
+}
+
 # Copyright 2011 Virgilio Gomez-Rubio
 # a function to export from nb object to a particular file format
 # which is used by INLA when fitting spatial models for lattice data
@@ -185,3 +200,49 @@ nb2INLA <-function(file, nb)
         }
 }
 
+read.swmdbf2listw <- function(fn, region.id=NULL, style=NULL, zero.policy=NULL) {
+    if (is.null(zero.policy))
+        zero.policy <- get.ZeroPolicyOption()
+    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")
+
+    res <- NULL
+
+    if (requireNamespace("foreign", quietly=TRUE)) {
+        df <- try(foreign::read.dbf(fn, as.is=TRUE), silent=TRUE)
+        if (inherits(df, "try-error")) stop(df[1])
+        if (is.null(region.id)) {
+            rn <- range(c(df[,2], df[,3]))
+            region.id <- as.character(rn[1]:rn[2])
+            warning("region.id not given, c(MYID, NID) range is ",
+                paste(rn, collapse=":"))
+        }
+        n <- length(region.id)
+        ids <- 1:n
+        df[,2] <- match(df[, 2], region.id)
+        if (anyNA(df[,2])) warning("NAs in MYID matching")
+        df[,3] <- match(df[, 3], region.id)
+        if (anyNA(df[,3])) warning("NAs in NID matching")
+        if (!all(df[,2] %in% ids) || !all(df[,3] %in% ids))
+            warning("some IDs missing")
+        df1 <- df[order(df[,2], df[,3]), -1]
+        attr(df1, "n") <- n
+        class(df1) <- c(class(df1), "spatial.neighbour")
+        attr(df1, "region.id") <- region.id
+        res0 <- try(sn2listw(df1, style=style, zero.policy=zero.policy),
+            silent=TRUE)
+        if (inherits(res0, "try-error")) stop(res0[1])
+        else res <- res0
+    } else warning("foreign::read.dbf not available")
+
+    if (!inherits(res, "listw")) warning("creation of listw object from SWM DBF file failed")
+    res
+}
+
+read_swm_dbf <- function(fn) {
+    read.swmdbf2listw(fn, style="B")
+}

man/read.gwt2nb.Rd

@@ -3,7 +3,10 @@
 \alias{read.gwt2nb}
 \alias{write.sn2gwt}
 \alias{read.dat2listw}
+\alias{read.swmdbf2listw}
+\alias{read_swm_dbf}
 \alias{write.sn2dat}
+\alias{write.sn2DBF}
 %- Also NEED an '\alias' for EACH other topic documented here.
 \title{Read and write spatial neighbour files}
 \description{
@@ -14,22 +17,27 @@ read.gwt2nb(file, region.id=NULL)
 write.sn2gwt(sn, file, shpfile=NULL, ind=NULL, useInd=FALSE, legacy=FALSE)
 read.dat2listw(file)
 write.sn2dat(sn, file)
+read.swmdbf2listw(fn, region.id=NULL, style=NULL, zero.policy=NULL)
+read_swm_dbf(fn)
+write.sn2DBF(sn, file)
 }
 %- maybe also 'usage' for other objects documented here.
 \arguments{
-  \item{file}{name of file with weights data}
-  \item{region.id}{region IDs}
+  \item{file, fn}{name of file with weights data}
+  \item{region.id}{a character vector of region IDs - for ArcGIS SWM DBFs, the values must be character integers (only numbers not starting with zero)}
   \item{sn}{a \code{spatial.neighbour} object}
   \item{shpfile}{character string: if not given Shapefile name taken from GWT file for this dataset}
   \item{ind}{character string: region id indicator field name}
   \item{useInd}{default FALSE, if TRUE, write \code{region.id} attribute ID key tags to output file (use in OpenGeoDa will depend on the shapefile having the field named in the \code{ind} argument matching the exported tags)}
   \item{legacy}{default FALSE; if TRUE, header has single field with number of observations only}
+  \item{style}{default NULL, missing, set to "M" and warning given; if not "M", passed to \code{\link{nb2listw}} to re-build the object}
+  \item{zero.policy}{default NULL, use global option value; if FALSE stop with error for any empty neighbour sets, if TRUE permit the weights list to be formed with zero-length weights vectors}
 }
 \details{
-Attempts to honour the region.id argument given when reading GWT files. If the region IDs given in \code{region.id=} do not match the origins or destinations in the GWT file, an error will be thrown reporting \code{Error: !anyNA(reg*dij) is not TRUE} where '*' may be \sQuote{o} for origins or \sQuote{d} for destinations.
+Attempts to honour the region.id argument given when reading GWT and SWM/DBF files. If the region IDs given in \code{region.id=} do not match the origins or destinations in the GWT file, an error or warning will be thrown, which should be considered carefully. \code{read_swm_dbf} is a simplified interface to \code{read.swmdbf2listw} When no-neighbour observations are present, it is advised that \code{region.id=} be given in \code{read.swmdbf2listw}; while the function should read correctly if the minimum and maximum IDs are present as observations with neighbours without \code{region.id=} set, reading using \code{read.swmdbf2listw} will fail when the minimum or maximum ID observations have no neighbours and \code{region.id=} is not given.
 }
 \value{
-  \code{read.gwt2nb} returns a neighbour "nb" object with the generalised weights stored as a list element called "dlist" of the "GeoDa" attribute.
+  \code{read.gwt2nb} returns a neighbour "nb" object with the generalised weights stored as a list element called "dlist" of the "GeoDa" attribute; \code{read.swmdbf2listw} returns a "listw" object read from a DBF file exported from an ArcGIS SWM object.
 }
 
 \references{Luc Anselin (2003) \emph{GeoDa 0.9 User's Guide}, pp. 80--81, Spatial Analysis Laboratory, Department of Agricultural and Consumer Economics, University of Illinois, Urbana-Champaign, \url{http://geodacenter.github.io/docs/geoda093.pdf}; also material formerly at spatial-econometrics.com/data/contents.html}
@@ -61,5 +69,50 @@ diffnb(listwmat1$neighbours, COL.nb, verbose=TRUE)
 listwmat2 <- read.dat2listw(system.file("etc/weights/wmat.dat", 
  package="spdep")[1])
 diffnb(listwmat1$neighbours, listwmat2$neighbours, verbose=TRUE)
+if (require("foreign", quietly=TRUE)) {
+nc_sf <- sf::st_read(system.file("gpkg/nc.gpkg", package="sf")[1])
+nc_sf$UniqueID <- 1:nrow(nc_sf)
+fn <- system.file("etc/misc/nc_contiguity_unique_id.dbf", package="spdep")[1]
+nc1 <- read.swmdbf2listw(fn, style="B")
+nc1
+nc1a <- read.swmdbf2listw(fn, region.id=as.character(nc_sf$UniqueID),
+ style="B")
+all.equal(nc1, nc1a)
+fn <- system.file("etc/misc/nc_contiguity_unique_id_islands.dbf",
+ package="spdep")[1]
+try(nc1i <- read.swmdbf2listw(fn, style="B"))
+nc1i <- read.swmdbf2listw(fn, style="B", zero.policy=TRUE)
+nc1ia <- read.swmdbf2listw(fn, region.id=as.character(nc_sf$UniqueID),
+ style="B", zero.policy=TRUE)
+nc1ia
+all.equal(nc1i, nc1ia)
+cal <- st_read(system.file("etc/shapes/california.gpkg", package="spdep")[1])
+fn <- system.file("etc/misc/contiguity_myid.dbf", package="spdep")[1]
+cal1 <- read.swmdbf2listw(fn, style="B")
+cal1a <- read.swmdbf2listw(fn, region.id=as.character(cal$MYID), style="B")
+all.equal(cal1, cal1a)
+fn <- system.file("etc/misc/contiguity_unique_id.dbf", package="spdep")[1]
+cal2 <- read.swmdbf2listw(fn, style="B")
+cal2a <- read.swmdbf2listw(fn, region.id=as.character(cal$UniqueID), style="B")
+all.equal(cal2, cal2a)
+fn <- system.file("etc/misc/contiguity_unique_id_islands.dbf", package="spdep")[1]
+try(cal3i <- read.swmdbf2listw(fn, style="B"))
+cal3i <- read.swmdbf2listw(fn, style="B", zero.policy=TRUE)
+cal3ia <- read.swmdbf2listw(fn, region.id=as.character(cal$UniqueID), style="B", zero.policy=TRUE)
+all.equal(cal3i, cal3ia)
+cal1a_1n_nb <- cal1a$neighbours
+cal1a_1n_nb <- droplinks(cal1a_1n_nb, drop=c("158", "180", "215"), sym=TRUE)
+cal1a_1n <- nb2listw(cal1a_1n_nb, style="B", zero.policy=TRUE)
+cal1a_1n_sn <- listw2sn(cal1a_1n)
+file <- tempfile(fileext=".dbf")
+write.sn2DBF(cal1a_1n_sn, file)
+cal1a_1n_rt <- read.swmdbf2listw(file, region.id=as.character(cal$MYID),
+ style="B", zero.policy=TRUE)
+all.equal(cal1a_1n$neighbours, cal1a_1n_rt$neighbours)
+all.equal(cal1a_1n$weights, cal1a_1n_rt$weights, check.attributes=FALSE)
+cal1_1n_rt <- read.swmdbf2listw(file, style="B", zero.policy=TRUE)
+all(isTRUE(all.equal(cal1a_1n$neighbours, cal1_1n_rt$neighbours)))
+all(isTRUE(all.equal(cal1a_1n$weights, cal1_1n_rt$weights)))
+}
 }
 \keyword{spatial}