Graphs that are non-isomorphic but have identical betweenness / degree / spectrum etc..

Code to identify a smallest pair of non-isomorphic, connected, undirected graphs that share certain properties:
i)   Share the same degree multiset
ii)  Share the same adjacency spectrum
iii) Share the same laplacian spectrum
iv) Share the same betweenness multiset
v)  Share the same (degree, betweenness) multiset
vi) Share the same adjacency and laplacian spectrum

We consider a graph g1 smaller than g2 if |V(g1)| < |V(g2)| OR |E(g1)| < |E(g2)|

#####################################################
library(igraph)
library(Matrix)

# See other blogposts for make_all_graphs(n) function

####################################################

get_matching_graph_pairs <- function(

    graphset,

    matchset = c('deg', 'bet', 'adjspec', 'lapspec'),

    digits = 10

    ){

  vertex.matchset <- intersect(matchset, c('deg', 'bet'))

  spectrum.matchset  <- intersect(matchset, c('adjspec', 'lapspec'))

  graph.statistics <- NULL

  

  # vertex level matchings
  if(length(vertex.matchset) > 0){

    vertex.statistics <- lapply(graphset, function(g){

      stats.list <- lapply(vertex.matchset, function(vm){

        if(vm == 'deg'){return(data.frame(deg = degree(g)))}

        if(vm == 'bet'){return(data.frame(bet = betweenness(g)))}

        })

      stats.df <- do.call('cbind', stats.list)

      # order the rows by the arbitrary columns:

      stats.df[do.call(order, stats.df), ]

      return(unlist(stats.df))

      })

    vertex.statistics <- do.call('rbind', vertex.statistics)

    graph.statistics <- vertex.statistics
    }

  
  # spectrum matchings

  # Uses Charpoly function as defined in a previous blog
  if(length(spectrum.matchset) > 0){
    spec.statistics <- lapply(graphset, function(g){
      stats.list <- lapply(spectrum.matchset, function(sm){
        if(sm == 'adjspec'){
          return(data.frame(adj = Charpoly(get.adjacency(g))))
          }
        if(sm == 'lapspec'){
          return(data.frame(lap = Charpoly(graph.laplacian(g))))
          }
        })
      stats.df <- do.call('cbind', stats.list)
      return(unlist(stats.df))
      })
    spec.statistics <- do.call('rbind', spec.statistics)
    if(!is.null(graph.statistics)){
      graph.statistics <- cbind(graph.statistics, spec.statistics)
      } else {
      graph.statistics <- spec.statistics
      }
    }

  dups.rows <- which(duplicated(round(

    graph.statistics, digits = digits

    )))

  

  if(length(dups.rows) > 0){

    r <- dups.rows[1]

    rep.matrix <- matrix(

      graph.statistics[r, ],

      nrow = nrow(graph.statistics),

      ncol = ncol(graph.statistics),

      byrow = TRUE

      )

    delta.matrix <- round(graph.statistics - rep.matrix,

                          digits = digits)

    matching.rows <- which(rowSums(abs(delta.matrix)) == 0)

    stopifnot(length(matching.rows) > 1)

    return(graphset[matching.rows[1:2]])

    }

  return(NULL)

  }

####################################################

get_smallest_match <- function(

  matchset = c('deg', 'bet', 'adjspec', 'lapspec'),

  max.vertices = 8,

  digits = 10   

  ){

  # Consider only connected graphs

  # Start from n = 3 vertices, since only 1 graph when n<=2

  for (n in 3:max.vertices){

    # Get a list of all connected, non-isomorphic graphs 

    #   on n vertices

    graphset <- Filter(is_connected, make_all_graphs(n))

    

    # Obtain a list of two graphs that match for all of 

    #   the reqd statistics (if possible) and return them

    #   to the user:

    matching.graphs <- get_matching_graph_pairs(

      graphset,

      matchset,

      digits

      )

    if(!is.null(matching.graphs)){

      return(matching.graphs)

      }

    }

  # No graphs could be found that matched on the required statistics

  return(NULL)

  }

###########################################

With the above code, we can find the smallest pair of graphs that are non-isomorphic, but which have the same 

i) degree distribution:

deg.match <- get_smallest_match('deg')

> lapply(deg.match, degree)
[[1]]
[1] 3 2 2 2 1

[[2]]
[1] 3 2 2 2 1

> lapply(deg.match, betweenness)
[[1]]
[1] 3.5 1.0 1.0 0.5 0.0

[[2]]

[1] 4 0 0 3 0

ii) Betweenness distribution

bet.match <- get_smallest_match('bet')

> lapply(bet.match, degree)
[[1]]
[1] 6 2 2 2 2 2 2

[[2]]
[1] 6 3 3 3 1 1 1

> lapply(bet.match, betweenness)
[[1]]
[1] 12  0  0  0  0  0  0

[[2]]
[1] 12  0  0  0  0  0  0

iii) Distribution of (degree, betweenness) ordered pairs
Note the adjacency eigenvalues differ for these two graphs

db.match  <- get_smallest_match(c('deg', 'bet'))

> lapply(db.match, degree)
[[1]]
[1] 4 4 4 4 4 4 4 4

[[2]]
[1] 4 4 4 4 4 4 4 4

> lapply(db.match, betweenness)
[[1]]
[1] 1.5 1.5 1.5 1.5 1.5 1.5 1.5 1.5

[[2]]
[1] 1.5 1.5 1.5 1.5 1.5 1.5 1.5 1.5

> lapply(db.match, function(x) round(eigen(get.adjacency(x))$values, 10))
[[1]]
[1]  4  2  0  0  0 -2 -2 -2

[[2]]
[1]  4.000000  1.414214  1.414214  0.000000 -1.414214 -1.414214 -2.000000
[8] -2.000000

iv) Adjacency spectrum

adj.match <- get_smallest_match('adjspec')

lapply(adj.match, plot)

v) Laplacian spectrum

lap.match <- get_smallest_match('lapspec')

lapply(lap.match, plot)

vi) Adjacency spectrum and Degree:

da.match <- get_smallest_match(c('deg', 'adjspec'))

vii) Laplacian spectrum and Degree:

dl.match <- get_smallest_match(c('lapspec', 'deg'))

Note that I could not find a pair of graphs on <= 9 vertices (code is pretty slow for > 8 vertices though) that had 
- both identical Laplacian spectrum and identical adjacency spectrum
- both identical adjacency spectrum and betweenness distribution
- both identical Laplacian spectrum and betweenness distribution