Calculate the length of shared boundaries between multiple polygons

Question

I have a shapefile and I want to know for each polygon what other polygons touch it. To that end I have this code:

require("rgdal")  
require("rgeos")

download.file("https://www.dropbox.com/s/vbxx9dic34qwz63/Polygons.zip?dl=1", "Polygons.zip")

Shapefile <- readOGR(".","Polygons")

Touching_List <- gTouches(Shapefile, byid = TRUE, returnDense=FALSE)

Touching_DF <- setNames(stack(lapply(Touching_List, as.character)), c("TOUCHING", "ORIGIN"))

I now want to go further and understand the extent to which each polygon touch other polygons. What I am after for each row in Touching_DF is a total length/perimeter for each ORIGIN polygon and the total length that each TOUCHING polygon is touching the origin polygon. This will then allow the percentage of the shared boundary to be calculated. I can imagine the output of this would be 3 new columns in Touching_DF (e.g. for the first row it could be something like origin parameter 1000m, touching length 500m, shared boundary 50%). Thanks.

EDIT 1

I have applied @StatnMap's answer to my real dataset. It appears that gTouches is returning results if a polygon shares both an edge and a point. These points are causing issues because they have no length. I have modified StatnMap's portion of code to deal with it, but when it comes to creating the data frame at the end there is a mismatch between how many shared edges/vertices gTouches returns and how many edges have lengths.

Here is some code to demonstrate the problem using a sample of my actual dataset:

library(rgdal)  
library(rgeos)
library(sp)
library(raster)

download.file("https://www.dropbox.com/s/hsnrdfthut6klqn/Sample.zip?dl=1", "Sample.zip")

unzip("Sample.zip")
Shapefile <- readOGR(".","Sample")

Touching_List <- gTouches(Shapefile, byid = TRUE, returnDense=FALSE)

# ---- Calculate perimeters of all polygons ----
perimeters <- sp::SpatialLinesLengths(as(Shapefile, "SpatialLines"))

# ---- All in a lapply loop ----
all.length.list <- lapply(1:length(Touching_List), function(from) {
  lines <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]],], byid = TRUE)
  if(class(lines) != "SpatialLines"){lines <- lines@lineobj}
  l_lines <- sp::SpatialLinesLengths(lines, longlat=FALSE)
  results <- data.frame(origin = from,
                    perimeter = perimeters[from],
                    touching = Touching_List[[from]],
                    t.length = l_lines,
                    t.pc = 100*l_lines/perimeters[from])
  results
})

This specifically shows the issue for one of the polygons:

from <- 4
lines <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]],], byid = TRUE)
if(class(lines) != "SpatialLines"){lines <- lines@lineobj}
l_lines <- sp::SpatialLinesLengths(lines, longlat=FALSE)

plot(Shapefile[c(from, Touching_List[[from]]),])
plot(lines, add = TRUE, col = 1 + 1:length(Touching_List[[from]]), lwd = 2)

The two possible solutions I see are 1. getting gTouches to return only shared edges with a length greater than zero or 2. returning a length of zero (rather than error) when a point rather than an edge is encountered. So far I can't find anything that will do either of these things.

EDIT 2

@StatnMap's revised solution works great. However, if a polygon does not share a snapped boarder with its neighbouring polygon (i.e. it goes to a point and then creates an island slither polygon) then it comes up with this error after lines <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]],], byid = TRUE)

   Error in RGEOSBinTopoFunc(spgeom1, spgeom2, byid, id, drop_lower_td, unaryUnion_if_byid_false,  : 
      Geometry collections may not contain other geometry collections

I have been looking for a solution that is able to identify polygons with badly drawn borders and not perform any calculations and return 'NA' in res (so they can still be identified later). However, I have been unable to find a command that distinguishes these problematic polygons from 'normal' polygons.

Running @StatnMap's revised solution with these 8 polygons demonstrates the issue:

download.file("https://www.dropbox.com/s/ttg2mi2nq1gbbrq/Bad_Polygon.zip?dl=1", "Bad_Polygon.zip")
unzip("Bad_Polygon.zip")
Shapefile <- readOGR(".","Bad_Polygon")

Answer 1

The intersection of two polygons only touching themselves is a line. Calculating a line length is easy with functions of spatial libraries in R.
As you started your example with library sp, you'll find a proposition with this library. However, I also give you a proposition with the new library sf.

Calculate polygons shared boundaries lengths with library sp

require("rgdal")  
require("rgeos")
library(sp)
library(raster)

download.file("https://www.dropbox.com/s/vbxx9dic34qwz63/Polygons.zip?dl=1", "Polygons.zip")

unzip("Polygons.zip")
Shapefile <- readOGR(".","Polygons")

Touching_List <- gTouches(Shapefile, byid = TRUE, returnDense=FALSE)

# Touching_DF <- setNames(utils::stack(lapply(Touching_List, as.character)), c("TOUCHING", "ORIGIN"))

# ---- Calculate perimeters of all polygons ----
perimeters <- sp::SpatialLinesLengths(as(Shapefile, "SpatialLines"))

# ---- Example with the first object of the list and first neighbor ----
from <- 1
to <- 1
line <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]][to],])
l_line <- sp::SpatialLinesLengths(line)

plot(Shapefile[c(from, Touching_List[[from]][to]),])
plot(line, add = TRUE, col = "red", lwd = 2)

# ---- Example with the first object of the list and all neighbors ----
from <- 1
lines <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]],], byid = TRUE)
l_lines <- sp::SpatialLinesLengths(lines)

plot(Shapefile[c(from, Touching_List[[from]]),])
plot(lines, add = TRUE, col = 1 + 1:length(Touching_List[[from]]), lwd = 2)

# ---- All in a lapply loop ----
all.length.list <- lapply(1:length(Touching_List), function(from) {
  lines <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]],], byid = TRUE)
  l_lines <- sp::SpatialLinesLengths(lines)
  res <- data.frame(origin = from,
                    perimeter = perimeters[from],
                    touching = Touching_List[[from]],
                    t.length = l_lines,
                    t.pc = 100*l_lines/perimeters[from])
  res
})

# ---- Retrieve as a dataframe ----
all.length.df <- do.call("rbind", all.length.list)

In the table above, t.length is the touching length and t.pc is the touching percentage with regards to the perimeter of the polygon of origin.

Edit: Some shared boundaries are points (with sp)

As commented, some frontiers may be a unique point instead of lines. To account for this case, I suggest to double the coordinates of the point to create a line of length=0. This requires to calculate intersections with other polygons one by one, when this case appear.
For a single polygon, we can test this:

# Example with the first object of the list and all neighbours
from <- 4
lines <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]],], byid = TRUE)
# If lines and points, need to do it one by one to find the point
if (class(lines) == "SpatialCollections") {
  list.Lines <- lapply(1:length(Touching_List[[from]]), function(to) {
    line.single <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]][to],])
    if (class(line.single) == "SpatialPoints") {
      # Double the point to create a line
      L1 <- rbind(line.single@coords, line.single@coords)
      rownames(L1) <- letters[1:2]
      Sl1 <- Line(L1)
      Lines.single <- Lines(list(Sl1), ID = as.character(to))
    } else if (class(line.single) == "SpatialLines") {
      Lines.single <- line.single@lines[[1]]
      Lines.single@ID <- as.character(to)
    }
    Lines.single
  })
  lines <- SpatialLines(list.Lines)
}

l_lines <- sp::SpatialLinesLengths(lines)

plot(Shapefile[c(from, Touching_List[[from]]),])
plot(lines, add = TRUE, col = 1 + 1:length(Touching_List[[from]]), lwd = 2)

For all in a lapply loop:

# Corrected for point outputs: All in a lapply loop
all.length.list <- lapply(1:length(Touching_List), function(from) {
  lines <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]],], byid = TRUE)
  if (class(lines) == "SpatialCollections") {
    list.Lines <- lapply(1:length(Touching_List[[from]]), function(to) {
      line.single <- rgeos::gIntersection(Shapefile[from,], Shapefile[Touching_List[[from]][to],])
      if (class(line.single) == "SpatialPoints") {
        # Double the point to create a line
        L1 <- rbind(line.single@coords, line.single@coords)
        rownames(L1) <- letters[1:2]
        Sl1 <- Line(L1)
        Lines.single <- Lines(list(Sl1), ID = as.character(to))
      } else if (class(line.single) == "SpatialLines") {
        Lines.single <- line.single@lines[[1]]
        Lines.single@ID <- as.character(to)
      }
      Lines.single
    })
    lines <- SpatialLines(list.Lines)
  }
  l_lines <- sp::SpatialLinesLengths(lines)
  res <- data.frame(origin = from,
                    perimeter = perimeters[from],
                    touching = Touching_List[[from]],
                    t.length = l_lines,
                    t.pc = 100*l_lines/perimeters[from])
  res
})

all.length.df <- do.call("rbind", all.length.list)

This may also be applied with library sf, but as you apparently chose to work with sp, I won't update the code for this part. Maybe later...

---- End of Edit ----

Calculate polygons shared boundaries lengths with library sf

Figures and outputs are the same.

library(sf)
Shapefile.sf <- st_read(".","Polygons")

# ---- Touching list ----
Touching_List <- st_touches(Shapefile.sf)
# ---- Polygons perimeters ----
perimeters <- st_length(Shapefile.sf)

# ---- Example with the first object of the list and first neighbour ----
from <- 1
to <- 1
line <- st_intersection(Shapefile.sf[from,], Shapefile.sf[Touching_List[[from]][to],])
l_line <- st_length(line)

plot(Shapefile.sf[c(from, Touching_List[[from]][to]),])
plot(line, add = TRUE, col = "red", lwd = 2)

# ---- Example with the first object of the list and all neighbours ----
from <- 1
lines <- st_intersection(Shapefile.sf[from,], Shapefile.sf[Touching_List[[from]],])
lines <- st_cast(lines) # In case of multiple geometries (ex. from=71)
l_lines <- st_length(lines)

plot(Shapefile.sf[c(from, Touching_List[[from]]),])
plot(lines, add = TRUE, col = 1:length(Touching_List[[from]]), lwd = 2)

# ---- All in a lapply loop ----
all.length.list <- lapply(1:length(Touching_List), function(from) {
  lines <- st_intersection(Shapefile.sf[from,], Shapefile.sf[Touching_List[[from]],])
  lines <- st_cast(lines) # In case of multiple geometries
  l_lines <- st_length(lines)
  res <- data.frame(origin = from,
                    perimeter = as.vector(perimeters[from]),
                    touching = Touching_List[[from]],
                    t.length = as.vector(l_lines),
                    t.pc = as.vector(100*l_lines/perimeters[from]))
  res
})

# ---- Retrieve as dataframe ----
all.length.df <- do.call("rbind", all.length.list)