Exploring graph substructures with topological obstacles (missing nodes)

latticeWObstacles.R

####
# Dependencies
####

library(tidyverse)
library(igraph)

####
# The pattern is to identify points to extend the structure of  
# dyads and subsequent structures
# And make sure the extension isn't already part of the structure
####

initialTwoStar <- function(g){
  #the third node can come frome either the head or tail
  tailEgo <- adjacent_vertices(g, tail_of(g, E(g)))
  headEgo <- adjacent_vertices(g, head_of(g, E(g)))
  
  third <- map2(tailEgo, headEgo, function(x, y){
    c(x,y) %>% as.integer() %>% unique
  })
  
  #the third node is an extension, so we want to make sure
  #it isn't already part of the structure
  igraph::as_data_frame(g) %>%
    mutate(third = third) %>%
    unnest %>%
    filter(third != from,
           third != to)
}


#every node that is added onto the structure needs a 
#"location" node to attach to that alread exists on the structure
#and this a "name" to refer to for future potential extensions
extendStructure <- function(pathList, g, location, name){
  v <- pathList[[location]] %>%
    adjacent_vertices(g, v = .) %>%
    map(as.integer) %>%
    #any node we include in the extension can't already exist in the structure
    imap(function(x,i){
      x[!x %in% pathList[i,]]
    })

  pathList[[name]] <- v
  unnest(pathList)
}

#remove duplicates when finishing up the structure
#anti receives a list of pathLists (structures) that we want to make 
#sure don't overlap with the the current structure
#lines and Ys can have the same list of nodes
cleanStructure <- function(pathList, anti = NULL){
  cleanedPL <- pathList %>%
    apply(1, sort) %>%
    t %>%
    as.data.frame()
 
  for(x in anti){
    cleanedPL <- anti_join(cleanedPL, x)
  }
  
  cleanedPL %>% distinct
}

pathListLine <- g2 %>%
  initialTwoStar() %>%
  extendStructure(g2, 'third', 'fourth') %>%
  extendStructure(g2, 'fourth', 'fifth') %>%
  cleanStructure()

pathListY <- g2 %>%
  initialTwoStar() %>%
  extendStructure(g2, 'third', 'fourth') %>%
  extendStructure(g2, 'third', 'fifth') %>%
  cleanStructure(list(pathListLine))

#whenever you do anything to a 'to' node you should
#do it for the 'from' node as well
pathList4Star <- lapply(c('from', 'to'), function(x){
  g2 %>%
    initialTwoStar() %>%
    extendStructure(g2, x, 'fourth') %>%
    extendStructure(g2, x, 'fifth') %>%
    cleanStructure(list(pathListLine, pathListY))
}) %>%
  bind_rows() %>%
  distinct()

####===================
# Example with 300 nodes in a 400 node lattice
####===================


x = 20
y = 20
g <- make_lattice(c(x, y))

#let's define a layout so we can visualize the structures 
myLayout <- c()
for(i in 1:x){
  for(j in 1:y){
    myLayout <- c(myLayout, c(i, j))
  }
}

myLayout <- matrix(myLayout, ncol = 2, byrow = T)

plot( g, layout = myLayout, vertex.label = '', vertex.size = 2)


#let's remove some nodes to represent obstacles in our topology
doNotUse <- sample(V(g), 100)

V(g)$doNotUse <- sapply(V(g), function(x){
  x %in% doNotUse
})

g <- g - V(g)[V(g)$doNotUse]

#remove the rows of the layout that correspond to the nodes we removed
myLayout <- myLayout[-c(doNotUse),]

plot( g, layout = myLayout, vertex.label = '', vertex.size = 2)


####
# Time to get the structrues
####

pathListLine <- g %>%
  initialTwoStar() %>%
  extendStructure(g, 'third', 'fourth') %>%
  extendStructure(g, 'fourth', 'fifth') %>%
  cleanStructure()

pathListY <- g %>%
  initialTwoStar() %>%
  extendStructure(g, 'third', 'fourth') %>%
  extendStructure(g, 'third', 'fifth') %>%
  cleanStructure(list(pathListLine))

#whenever you do anything to a 'to' node you should
#do it for the 'from' node as well. This is due to natural symmetry
pathList4Star <- lapply(c('from', 'to'), function(x){
  g %>%
    initialTwoStar() %>%
    extendStructure(g, x, 'fourth') %>%
    extendStructure(g, x, 'fifth') %>%
    cleanStructure(list(pathListLine, pathListY))
}) %>%
  bind_rows() %>%
  distinct()

allPathList5 <- list(pathListLine, pathList4Star, pathListY) %>%
  bind_rows() 


#As a sanity check, let's make a gif and show a small sample of all structures
library(animation)

saveGIF({
  ani.options(interval = 0.4)
  s <- sample_n(allPathList5, 100)
  lapply(seq(nrow(s)), function(i){
    plot(g,
         vertex.color = sapply(V(g), function(x){ifelse(x %in% s[i,], 'black', 'antiquewhite')}),
         vertex.size = 3,
         vertex.label = '',
         layout = myLayout)
  })
}, movie.name = "100_length5_20x20_400.gif", ani.width = 800, ani.height = 800)