complete subgraphs vignette

NAMESPACE

@@ -34,7 +34,8 @@ exportMethods(coerce)
 
 export(EBImoran.mc, probmap, choynowski, EBest, EBlocal)
 
-export(airdist, card, cell2nb, vi2mrc, n.comp.nb, diffnb, dnearneigh, droplinks)
+export(airdist, card, cell2nb, vi2mrc, n.comp.nb, diffnb, dnearneigh, droplinks,
+	addlinks1)
 
 export(gabrielneigh, geary.test, geary, geary.mc, globalG.test, graph2nb,
 	joincount.test, joincount.mc, joincount.multi, print.jcmulti,

R/droplinks.R

@@ -1,4 +1,4 @@
-# Copyright 2001-8 by Roger Bivand 
+# Copyright 2001-24 by Roger Bivand 
 #
 
 droplinks <- function(nb, drop, sym=TRUE) {
@@ -30,7 +30,11 @@ droplinks <- function(nb, drop, sym=TRUE) {
 		nb[[i]] <- 0L
 	}
 	nb <- sym.attr.nb(nb)
-        NE <- n + sum(card(nb))
+        cans <- card(nb)
+        if (get.NoNeighbourOption()) {
+            if (any(cans == 0L)) warning("some observations have no neighbours")
+        }
+        NE <- n + sum(cans)
         if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
             ncomp <- n.comp.nb(nb)
             attr(nb, "ncomp") <- ncomp
@@ -39,3 +43,47 @@ droplinks <- function(nb, drop, sym=TRUE) {
 	nb
 }
 
+addlinks1 <- function(nb, from, to, sym=TRUE) {
+  	if (!inherits(nb, "nb")) stop("not a neighbours list")
+        stopifnot(length(from) == 1L)
+	n <- length(nb)
+	cnb <- card(nb)
+	if (n < 1) stop("non-positive length of nb")
+	row.names <- as.character(attr(nb, "region.id"))
+	if (is.character(from)) {
+		ifrom <- match(from, row.names)
+		if(any(is.na(ifrom))) stop("from-region not found")
+	} else {
+		ifrom <- match(from, 1:n)
+		if (any(is.na(ifrom))) stop("from-region not found")
+	}
+	if (is.character(to)) {
+		ito <- match(to, row.names)
+		if (any(is.na(ito))) stop("to-region not found")
+	} else {
+		ito <- match(to, 1:n)
+		if(any(is.na(ito))) stop("to-region drop not found")
+	}
+	if ((attr(nb, "sym") == FALSE) && (sym == TRUE)) {
+		warning("setting sym to FALSE")
+		sym <- FALSE
+	}
+        orig <- nb[[ifrom]]
+        orig <- orig[orig > 0L]
+        nb[[ifrom]] <- as.integer(sort(unique(c(orig, ito))))
+        if (sym) {
+		for (i in ito) {
+			orig <- nb[[i]]
+			orig <- orig[orig > 0L]
+			nb[[i]] <- as.integer(sort(unique(c(orig, ifrom))))
+		}
+        }
+	nb <- sym.attr.nb(nb)
+        NE <- n + sum(card(nb))
+        if (get.SubgraphOption() && get.SubgraphCeiling() > NE) {
+            ncomp <- n.comp.nb(nb)
+            attr(nb, "ncomp") <- ncomp
+            if (ncomp$nc > 1) warning("neighbour object has ", ncomp$nc, " sub-graphs")
+        }
+	nb
+}

man/droplinks.Rd

@@ -1,18 +1,22 @@
 % Copyright 2001 by Roger S. Bivand
 \name{droplinks}
 \alias{droplinks}
-\title{Drop links in a neighbours list}
+\alias{addlinks1}
+\title{Drop  and add links in a neighbours list}
 \description{
- Drops links to and from or just to a region from a neighbours list. The example corresponds to Fingleton's Table 1, p. 6, for lattices 5 to 19.
+ \code{droplinks} drops links to and from or just to a region from a neighbours list. The example corresponds to Fingleton's Table 1, (1999) p. 6, for lattices 5 to 19. \code{addlinks1} adds links from a single region to specified regions.
 }
 \usage{
 droplinks(nb, drop, sym=TRUE)
+addlinks1(nb, from, to, sym=TRUE)
 }
 
 \arguments{
   \item{nb}{a neighbours list object of class \code{nb}}
   \item{drop}{either a logical vector the length of \code{nb}, or a character vector of named regions corresponding to \code{nb}'s region.id attribute, or an integer vector of region numbers}
-  \item{sym}{TRUE for removal of both "row" and "column" links, FALSE for only "row" links}
+  \item{sym}{TRUE for removal of both "row" and "column" links, FALSE for only "row" links; when adding links, inserts links to the from region from the to regions}
+  \item{from}{single from region for adding links, either a character vector of length 1 of the named from region corresponding to \code{nb}'s region.id attribute, or an integer vector of length 1 holding a region number}
+  \item{to}{to regions, either a character vector of named from regions corresponding to \code{nb}'s region.id attribute, or an integer vector of region numbers}
 }
 \value{
  The function returns an object of class \code{nb} with a list of integer vectors containing neighbour region number ids. 

vignettes/CO69.Rmd

@@ -657,7 +657,7 @@ to general does make a difference.
 print(formatC(res, format="f", digits=4), quote=FALSE)
 ```
 
-```{r results='asis',eval=run,echo=FALSE, fig.cap="Three contrasted spatial weights definitions"}
+```{r results='asis',eval=FALSE,echo=FALSE, fig.cap="Three contrasted spatial weights definitions"}
 pal <- grey.colors(9, 1, 0.5, 2.2)
 oopar <- par(mfrow=c(1,3), mar=c(1,1,3,1)+0.1)
 z <- t(listw2mat(nb_B))
@@ -679,7 +679,7 @@ par(oopar)
 \caption{Three contrasted spatial weights definitions.}
 \label{plot_wts}
 
-```{r results='asis',eval=run,echo=FALSE}
+```{r results='asis',eval=FALSE,echo=FALSE}
 eire_ge1$nb_B <- sapply(nb_B$weights, sum)
 eire_ge1$lw_unstand <- sapply(lw_unstand$weights, sum)
 library(lattice)

vignettes/nb.Rmd

@@ -115,7 +115,7 @@ isTRUE(all.equal(Sy0_nb, Sy2_nb, check.attributes=FALSE))
 run <- require("sp", quiet=TRUE)
 ```
 
-```{r, echo=run}
+```{r, echo=TRUE,eval=FALSE}
 oopar <- par(mfrow=c(1,2), mar=c(3,3,1,1)+0.1)
 plot(Syracuse, border="grey60")
 plot(Sy0_nb, coordinates(Syracuse), add=TRUE, pch=19, cex=0.6)
@@ -221,7 +221,7 @@ if (require(dbscan, quietly=TRUE)) {
 Sy6_nb <- graph2nb(gabrielneigh(coords), row.names=IDs)
 Sy7_nb <- graph2nb(relativeneigh(coords), row.names=IDs)
 ```
-```{r, echo=run}
+```{r, echo=run,eval=FALSE}
 oopar <- par(mfrow=c(2,2), mar=c(1,1,1,1)+0.1)
 plot(Syracuse, border="grey60")
 plot(Sy4_nb, coords, add=TRUE, pch=".")
@@ -295,7 +295,7 @@ sapply(nb_l, function(x) is.symmetric.nb(x, verbose=FALSE, force=TRUE))
 sapply(nb_l, function(x) n.comp.nb(x)$nc)
 ```
 
-```{r, echo=run}
+```{r, echo=run,eval=FALSE}
 oopar <- par(mfrow=c(1,3), mar=c(1,1,1,1)+0.1)
 plot(Syracuse, border="grey60")
 plot(Sy8_nb, coords, add=TRUE, pch=".")
@@ -339,7 +339,7 @@ sapply(nb_l, function(x) is.symmetric.nb(x, verbose=FALSE, force=TRUE))
 sapply(nb_l, function(x) n.comp.nb(x)$nc)
 ```
 
-```{r, echo=run}
+```{r, echo=run,eval=FALSE}
 oopar <- par(mfrow=c(1,3), mar=c(1,1,1,1)+0.1)
 plot(Syracuse, border="grey60")
 plot(Sy11_nb, coords, add=TRUE, pch=".")

vignettes/sids.Rmd

@@ -62,7 +62,7 @@ the extension, and were read here using `sf::st_read()` into the
 using the `st_centroid` method from **sf** as an **sfc** POINT object, and can
 be used to place labels after the extraction of the coordinate matrix:
 
-```{r echo=TRUE}
+```{r echo=TRUE,eval=FALSE}
 sf_use_s2(TRUE)
 plot(st_geometry(nc), axes=TRUE)
 text(st_coordinates(st_centroid(st_geometry(nc), of_largest_polygon=TRUE)), label=nc$FIPSNO, cex=0.5)
@@ -172,7 +172,7 @@ gal_file <- system.file("weights/ncCC89.gal", package="spData")[1]
 ncCC89 <- read.gal(gal_file, region.id=nc$FIPSNO)
 ncCC89
 ```
-```{r label=plot-CC89.nb, echo=TRUE}
+```{r label=plot-CC89.nb, echo=TRUE,eval=FALSE}
 plot(st_geometry(nc), border="grey")
 plot(ncCC89, st_centroid(st_geometry(nc), of_largest_polygon), add=TRUE, col="blue")
 ```