Fast contiguity checks for polygons in SF/R - r

Question

For my dissertation, I'm running an algorithm that creates random congressional districts by flipping precincts from one district to an adjacent district thousands of times. One important part in the analysis is that the district that gives the precinct cannot be rendered non-contiguous (i.e., it can't give up a precinct that connects one portion of a district to a different part). To check this, I utilize the following script:
library(sf)
library(tidyverse)
subtracted_district <- main_df %>% #main_df has all of the precincts
filter(district %in% giver) %>% #this selects only precincts in "giver" district
filter(!index %in% proposed) %>% #this removes the proposed precinct to be flipped to the "taker" district
summarise()
foo <- st_cast(subtracted_district, "POLYGON")
d <- dim(foo)[1]
ifelse(d == 1, accepted <- 1, adjoining_giver <- adjoining_giver[-a]) #if contiguous, it's accepted, otherwise, we start over without this precinct available.
In short, this pulls the precincts from the shapefiles that are assigned to the "giver" district, filters out the "proposed" donor precinct, reassembles the "giver" district without the proposed donor precinct, then checks to see if the reassembled district would be comprised of multiple polygons.
This works, but the problem is that even on my very fast desktop, recreating the district is prohibitively slow, especially if it has thousands of precincts in it. It ends up taking about an hour to run through.
I'm wondering if there is a way to do this without recreating the district. If you know the adjacency matrix for a group of polygons, is there a fast, reliable way to check to see if the group of polygons is contiguous?
Edit to address a comment: To be clear, the slow part comes with the sf/tidy command "summarise," which takes all of the precinct polygons and merges them into a district. This takes a huge amount of time, which is why I'm wondering if I can do it without having to actually create the district just by looking at the adjacency matrix.
Below is a sample main_df file, in sf format. The way it works now, a vector of indexes for the precincts in the "giver" district that are adjacent to the "taker" precinct are selected (not shown, but done through the adjacency matrix), and then a random precinct is selected from that vector as a proposed donation ("proposed").
If you were to create this shapefile and run the full code, 9, 11, 12 and 15 would be listed as possible precincts to flip from 17 to 13. It would then randomly select from that list a precinct to flip.
Let's say it proposes precinct 9 to donate. To test whether it was an acceptable proposal, the script takes main_df, filters out the precincts currently in district 17, then filters out precinct 9.
This is where things slow down: It then will merge together all of the precincts into a single district. It will be fast with this data, but very slow if you have, say, 2000 precincts in a district to merge.
It then uses st_cast to see if we are left with a multipolygon. If the resulting dataframe has more than 1 row, it does, the proposal is rejected, and it selects from the remaining data. Here it would break contiguity, so the proposal would be rejected and it would choose from 12, 11 and 15. If it chose 12, the proposal would fail, and it would select from 11 and 15. Whichever it chose, the proposal would be accepted, because it would not break contiguity.
Since creating the district slows things down so much, I'm wondering there's a fast way to do it via the adjacency matrix.
Sample adjacency matrix:
structure(list(12L, c(10L, 11L, 13L, 15L), c(8L, 10L, 12L, 15L
), c(5L, 13L), c(4L, 11L, 14L), c(9L, 11L, 14L), 14L, c(3L, 12L
), c(6L, 10L, 11L, 12L), c(2L, 3L, 9L, 11L, 12L, 15L), c(2L,
5L, 6L, 9L, 10L, 13L), c(1L, 3L, 8L, 9L, 10L), c(2L, 4L, 11L,
15L), 5:7, c(2L, 3L, 10L, 13L)), predicate = "relate_pattern", region.id = c("1",
"2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13",
"14", "15"), remove_self = FALSE, retain_unique = FALSE, ncol = 15L, class = c("sgbp",
"list"))
Sample shapefile:
structure(list(index = c(1L, 2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L,
10L, 11L, 12L, 15L, 18L, 19L), Total_pop = c(3951.064118, 37401.9916269,
1989.623112, 2679.000014, 2934.782304, 2193.129252, 3967.176508,
2916.376886, 1237.112553, 14039.899499, 9486.059285, 2805.5047867,
3240.0551608, 2230.911935, 11792.6263111), district = c(17, 13,
13, 17, 17, 17, 17, 13, 17, 13, 17, 17, 17, 17, 13), geometry = structure(list(
structure(list(structure(c(-84.320765, -84.314011, -84.309424,
-84.329215, -84.333127, -84.340251, -84.340531, -84.333975,
-84.329623, -84.323183, -84.320765, 40.859333, 40.859414,
40.847182, 40.841154, 40.829147, 40.828847, 40.859099, 40.859198,
40.859295, 40.859405, 40.859333), .Dim = c(11L, 2L))), class = c("XY",
"POLYGON", "sfg")), structure(list(structure(c(-84.108857,
-84.093944, -84.096841, -84.094248, -84.079782, -84.075252,
-84.070914, -84.094946, -84.090253, -84.075439, -84.075766,
-84.089857, -84.089814, -84.100991, -84.108197, -84.108219,
-84.108304, -84.113273, -84.123183, -84.143812, -84.152296,
-84.16154, -84.146775, -84.160499, -84.122984, -84.127923,
-84.121899, -84.10871, -84.108857, 40.795642, 40.788453,
40.77236, 40.752697, 40.745239, 40.730615, 40.717104, 40.716549,
40.709565, 40.709664, 40.702659, 40.699769, 40.688383, 40.687675,
40.695077, 40.698505, 40.709503, 40.724139, 40.7303, 40.73043,
40.726295, 40.730179, 40.737101, 40.754921, 40.751592, 40.764579,
40.769752, 40.770137, 40.795642), .Dim = c(29L, 2L))), class = c("XY",
"POLYGON", "sfg")), structure(list(structure(c(-84.340004,
-84.223661, -84.223143, -84.222799, -84.318213, -84.318511,
-84.339536, -84.340004, 40.772111, 40.773446, 40.729461,
40.685957, 40.685658, 40.714662, 40.714542, 40.772111), .Dim = c(8L,
2L))), class = c("XY", "POLYGON", "sfg")), structure(list(
structure(c(-83.994079, -83.994156, -83.879834, -83.880194,
-83.994079, 40.644132, 40.731146, 40.732443, 40.64469,
40.644132), .Dim = c(5L, 2L))), class = c("XY", "POLYGON",
"sfg")), structure(list(structure(c(-83.879834, -83.994156,
-83.994343, -83.880063, -83.879834, 40.732443, 40.731146,
40.81805, 40.819919, 40.732443), .Dim = c(5L, 2L))), class = c("XY",
"POLYGON", "sfg")), structure(list(structure(c(-83.995165,
-83.994343, -84.109248, -84.109586, -84.109516, -83.995165,
40.905066, 40.81805, 40.817277, 40.860994, 40.90473, 40.905066
), .Dim = c(6L, 2L))), class = c("XY", "POLYGON", "sfg")),
structure(list(structure(c(-83.880301, -83.890429, -83.904255,
-83.904832, -83.917586, -83.900224, -83.880402, -83.880393,
-83.880383, -83.880301, 40.881537, 40.877166, 40.879403,
40.892264, 40.898383, 40.905847, 40.905907, 40.901276, 40.898756,
40.881537), .Dim = c(10L, 2L))), class = c("XY", "POLYGON",
"sfg")), structure(list(structure(c(-84.340004, -84.339536,
-84.318511, -84.318213, -84.396778, -84.397189, -84.340016,
-84.340004, 40.772111, 40.714542, 40.714662, 40.685658, 40.684926,
40.786584, 40.786948, 40.772111), .Dim = c(8L, 2L))), class = c("XY",
"POLYGON", "sfg")), structure(list(structure(c(-84.22485,
-84.130459, -84.109586, -84.109248, -84.108904, -84.148307,
-84.22407, -84.22485, 40.859307, 40.860182, 40.860994, 40.817277,
40.802748, 40.801737, 40.801247, 40.859307), .Dim = c(8L,
2L))), class = c("XY", "POLYGON", "sfg")), structure(list(
structure(c(-84.223143, -84.223661, -84.22407, -84.148307,
-84.108904, -84.108857, -84.10871, -84.121899, -84.127923,
-84.122984, -84.160499, -84.146775, -84.16154, -84.223143,
40.729461, 40.773446, 40.801247, 40.801737, 40.802748,
40.795642, 40.770137, 40.769752, 40.764579, 40.751592,
40.754921, 40.737101, 40.730179, 40.729461), .Dim = c(14L,
2L))), class = c("XY", "POLYGON", "sfg")), structure(list(
structure(c(-84.108857, -84.108904, -84.109248, -83.994343,
-83.994156, -84.075252, -84.079782, -84.094248, -84.096841,
-84.093944, -84.108857, 40.795642, 40.802748, 40.817277,
40.81805, 40.731146, 40.730615, 40.745239, 40.752697,
40.77236, 40.788453, 40.795642), .Dim = c(11L, 2L))), class = c("XY",
"POLYGON", "sfg")), structure(list(structure(c(-84.340004,
-84.340016, -84.397189, -84.397374, -84.340101, -84.340251,
-84.333127, -84.329215, -84.309424, -84.314011, -84.22485,
-84.22407, -84.223661, -84.340004, 40.772111, 40.786948,
40.786584, 40.815941, 40.816143, 40.828847, 40.829147, 40.841154,
40.847182, 40.859414, 40.859307, 40.801247, 40.773446, 40.772111
), .Dim = c(14L, 2L))), class = c("XY", "POLYGON", "sfg")),
structure(list(structure(c(-83.994079, -84.107787, -84.107908,
-84.108197, -84.100991, -84.089814, -84.089857, -84.075766,
-84.075439, -84.090253, -84.094946, -84.070914, -84.075252,
-83.994156, -83.994079, 40.644132, 40.643069, 40.657938,
40.695077, 40.687675, 40.688383, 40.699769, 40.702659, 40.709664,
40.709565, 40.716549, 40.717104, 40.730615, 40.731146, 40.644132
), .Dim = c(15L, 2L))), class = c("XY", "POLYGON", "sfg")),
structure(list(structure(c(-83.880402, -83.900224, -83.917586,
-83.904832, -83.904255, -83.890429, -83.880301, -83.880063,
-83.994343, -83.995165, -83.995228, -83.880423, -83.880402,
40.905907, 40.905847, 40.898383, 40.892264, 40.879403, 40.877166,
40.881537, 40.819919, 40.81805, 40.905066, 40.919843, 40.920429,
40.905907), .Dim = c(13L, 2L))), class = c("XY", "POLYGON",
"sfg")), structure(list(structure(c(-84.222799, -84.223143,
-84.16154, -84.152296, -84.143812, -84.123183, -84.113273,
-84.108304, -84.108219, -84.108197, -84.107908, -84.222749,
-84.222799, 40.685957, 40.729461, 40.730179, 40.726295, 40.73043,
40.7303, 40.724139, 40.709503, 40.698505, 40.695077, 40.657938,
40.656948, 40.685957), .Dim = c(13L, 2L))), class = c("XY",
"POLYGON", "sfg"))), n_empty = 0L, crs = structure(list(input = "NAD83",
wkt = "GEOGCRS[\"NAD83\",\n DATUM[\"North American Datum 1983\",\n ELLIPSOID[\"GRS 1980\",6378137,298.257222101,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n CS[ellipsoidal,2],\n AXIS[\"latitude\",north,\n ORDER[1],\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n AXIS[\"longitude\",east,\n ORDER[2],\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n ID[\"EPSG\",4269]]"), class = "crs"), class = c("sfc_POLYGON",
"sfc"), precision = 0, bbox = structure(c(xmin = -84.397374,
ymin = 40.643069, xmax = -83.879834, ymax = 40.920429), class = "bbox"))), row.names = c(NA,
15L), sf_column = "geometry", agr = structure(c(index = NA_integer_,
Total_pop = NA_integer_, district = NA_integer_), .Label = c("constant",
"aggregate", "identity"), class = "factor"), class = c("sf",
"data.frame"))

Answer 1

This is an interesting problem and I believe it can be solved by via adjacency matrix.
I will illustrate a possible approach on the well known and much loved NC shapefile that ships with {sf}.
First I construct a subset of North Carolina that makes a contiguous polygon:
library(sf)
library(dplyr)
library(sfdep)
# the one & only NC shapefile...
nc <- st_read(system.file("shape/nc.shp", package="sf")) %>%
# round up the usual suspects...
filter(!NAME %in% c('Dare', 'Currituck', 'Carteret', 'Hyde'))
plot(st_geometry(nc))
Then I construct a adjacency matrix; I personally prefer sfdep::st_contiguity() but other approaches are possible.
The next step is iterating over the matrix, looking for matches between second degree neighbors (neighbors of a given neighbor) and first degree neighbors (neighbors of district / county being evaluated). Should you find a case of no common neighbor - you have your troublemaker!
You will have to first eliminate counties/districts that have only one neighbor. These can not cause discontinuity and are safely ignored (consider county Tyrell on what is left of the Albemarle-Pamlico Peninsula).
Once you have iterated over the entire adjacency matrix you are done.
neighbours <- sfdep::st_contiguity(nc)
troublemakers <- rep(FALSE, times = length(neighbours)) # init of an resultset
for (i in seq_along(neighbours)) {
first_degree <- neighbours[[i]]
# edge case of single neighbor districts needs to be handled;
# it can not create discontinuity and is safe to be ignored
if (length(first_degree) > 1) {
for (j in seq_along(first_degree)) {
# j-th second degree neighbors vs first degree neighbors
wrk_diff <- intersect(unlist(neighbours[first_degree[j]]),
first_degree)
# if no common neighbor >> discontinuity!
if (length(wrk_diff) == 0) troublemakers[i] <- T
}
}
}
And because a picture is worth 1000 of words - let us check the troublemakers on a plot (first all counties, and then overlay with a subset of troublemakers in red)
plot(st_geometry(nc))
plot(st_geometry(nc[troublemakers, ]), col = "red", add = T)