Exploring graph substructures with topological obstacles (missing nodes) and node weights

latticeWObstaclesTopology.R

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 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
}


####===================
# Example with 300 nodes in a 400 node lattice
# Terrain is added and nodes are given a score
# We are interested in 5 node graphs with a cumulative score of >16
####===================


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

#make terrain
terrainCenters <- sample(vcount(g), 2)
V(g)$terrain <- V(g) %in% terrainCenters
fullTerrain <- ego(g, 5, V(g)[terrain]) %>%
  unlist %>%
  unique
V(g)$terrain <- V(g) %in% fullTerrain
V(g)$color <- sapply(V(g)$terrain, function(x){ifelse(x, 'forestgreen', 'navajowhite')} )

#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 = 5)


#let's remove some nodes to represent obstacles in our topology
doNotUse <- sample(V(g)[!terrain], 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 = 4)

#accessibility
V(g)$score <- abs(degree(g) - 5)
V(g)$score <- map2_dbl(V(g)$score, V(g)$terrain, function(x,y){
  if(y){return(x * 1.5)}
  x
})

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

V(g)$size <- sapply(V(g)$score, function(x){ifelse(x >= 4, 10, 5 )})
####
# 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() %>%
  mutate(score = pmap_dbl(., function(V1, V2, V3, V4, V5){
    sapply(c(V1, V2, V3, V4, V5), function(x){
      V(g)[x]$score
    }) %>%
      sum
  })) %>%
  arrange(desc(score))

library(animation)

saveGIF({
  ani.options(interval = 0.75)
  s <- allPathList5 %>%
    filter(score >= 16)
  lapply(seq(nrow(s)), function(i){
    plot(g,
         vertex.color = map2_chr(V(g), V(g)$color, function(x, y){ifelse(x %in% s[i, 1:5], 'black', y)}),
         vertex.label = '',
         layout = myLayout)
    title(str_glue("Area of 5 with a score of {s[i,6]}\n",
                   "Nodes are given a score of abs(degree - 5)\n",
                   "Green nodes are given a multiplyer of 1.5"))
  })
}, movie.name = "gte16_terriain_length5_20x20_400.gif", ani.width = 800, ani.height = 800)