#####################################################
is_non_increasing <- function(v){
if(length(v) == 1){return(TRUE)}
diff <- v[1:(length(v) - 1)] - v[2:length(v)]
all(diff >= 0)
}
#####################################################
reduce_by_isomorphism_class <- function(adj.mats){
# Assume undirected, ie symmetrical matrices
# TODO - Find other simply calculated graph params
# from adjacency matrix to reduce # of calls
# to is_isomorphic_to
require(Matrix) # doesn't rank the zero matrix correctly
require(igraph)
degree.vecs <- t(sapply(adj.mats, colSums))
ranks <- sapply(adj.mats, rankMatrix)
eigs <- t(sapply(adj.mats, function(x) eigen(x)$values))
eigs.trunc <- round( eigs, 3 )
matrix.params <- cbind(degree.vecs, ranks, eigs.trunc)
# Convert the vector of (nonincreasing) degrees,
# the matrix rank, and the rounded eigenvalues
# into a single factor to permit quick matching prior to
# isomorphism tests
match.params <- data.frame(
mat = 1:length(adj.mats),
params = factor(
apply(matrix.params, 1,
function(row){paste(row, collapse = ' ')})
)
)
iso.classes <- lapply(levels(match.params$params),
function(par.str){
rows <- which(match.params$params == par.str)
temp.classes <- list()
temp.classes <- append(temp.classes, adj.mats[rows][1])
if(length(rows) > 1){
# drop adj.mats[current.row] if its is isomorphic
# to a graph in temp.classes
for(r in rows){
test.mat <- adj.mats[[r]]
test.g <- graph.adjacency(
test.mat,
'undirected'
)
iso.to.any <- sapply(temp.classes, function(storedmat){
stored.g <- graph.adjacency(
storedmat,
'undirected'
)
is_isomorphic_to(test.g, stored.g)
})
iso.to.any <- any(iso.to.any)
if(! iso.to.any){
temp.classes <- append(temp.classes, adj.mats[r])
}
}
}
temp.classes
})
do.call('c', iso.classes)
}
#####################################################
## all graphs on n vertices
make_all_adjMats <- function(n){
# not yet finished - works for n=1..8, but a bit slow
maxN = 10
stopifnot(n %in% seq(1, maxN))
if(n == 1){
return(
list(matrix(0, nrow = n, ncol = n))
)
}
adj.mats.lo <- lapply(
# append an extra vertex to each one-smaller adjacency matrix
make_all_adjMats(n-1),
function(m){
M <- matrix(0, nrow = n, ncol = n)
M[1:(n-1), 1:(n-1)] <- m
M
})
# all setwise combinations of 1:n-1, incl the empty set
all.combs <- lapply(0:(n-1), function(x) combn((n-1), x))
adj.mats <- lapply(adj.mats.lo, function(m){
sublist <- list()
# add edges for the new vertex, vertex n
for(combmat in all.combs){
if(nrow(combmat) == 0){
sublist <- append(sublist, list(m))
} else {
for(col in 1:ncol(combmat)){
comb <- combmat[, col]
temp.m <- m
temp.m[n, comb] <- 1
temp.m[comb, n] <- 1
# ensure deg(i)>=deg(i+1) for i=1..n-1
if(is_non_increasing(colSums(temp.m))){
sublist <- append(sublist, list(temp.m))
}
}
}
}
sublist
})
adj.mats <- do.call('c', adj.mats)
adj.mats <- adj.mats[order(sapply(adj.mats, sum))]
# Becomes slow for n = 7
# Methods to filter by isomorphism class?
# a - ensure deg(i) >= deg(i+1) - done
# b - group by degree vector and rank(ie, # connComp)
# then use is_isomorphic_to
adj.mats <- reduce_by_isomorphism_class(adj.mats)
adj.mats
}
####################################################
##
make_all_graphs <- function(n){
require(igraph)
# let vertices be 1..n and assume deg(i)<=deg(i+1) for all i
adj.mats <- make_all_adjMats(n)
graphs <- lapply(
adj.mats,
function(m){
graph_from_adjacency_matrix(
adjmatrix = m,
mode = 'undirected'
)})
graphs
}
#######################################################
library(igraph)
# Number of non-isomorphic connected graphs on 7 vertices:
system.time(G7 <- Filter(is.connected, make_all_graphs(7)))
# Without filtering on eigenvalues
# user system elapsed
# 3.35 0.00 3.37
# With filtering on eigenvalues
# user system elapsed
# 2.40 0.00 2.41
length(G7) # 524
G7.eigen.adj <- t(sapply(G7, function(g){
eigen(get.adjacency(g))$values
}))
length(which(duplicated(G7.eigen.adj))) # 1
length(which(duplicated(round(G7.eigen.adj, 10)))) # 21
G7.eigen.lap <- t(sapply(G7, function(g){
eigen(graph.laplacian(g))$values
}))
length(which(duplicated(G7.eigen.lap))) # 2
length(which(duplicated(round(G7.eigen.lap, 10)))) # 14
r <- intersect(
which(duplicated(round(G7.eigen.adj, 10))),
which(duplicated(round(G7.eigen.lap, 10)))
) # only 441
lapply(r, function(x){
temp <- G7.eigen.lap - matrix(
G7.eigen.lap[x, ],
nrow = nrow(G7.eigen.lap), ncol = 7, byrow = TRUE
)
which(rowSums(temp^2) < 0.001)
})
# 374, 375, 441
# 374 and 375 have identical degree vec
# 374 not.iso to 375 since 374 contains 3 maximal cliques and 375 contains 2 (max cliques being of size 4)
# rank(374)=5; rank(375)=6 can be seen using pracma::rref and Matrix::rankMatrix (nb, rank(441)=5 also)
# numerical rounding made it look like they had the same spectrum
eig.vs.bet <- t(sapply(G7, function(g){
lap <- graph.laplacian(g)
eig <- eigen(lap)
bet <- betweenness(g)
which.min.loading <- which.min(abs(eig$vectors[, 6]))
min.loading <- min(abs(eig$vectors[, 6]))
which.max.bet <- which.max(bet)
max.bet <- max(bet)
cbind(which.min.loading, min.loading, which.max.bet, max.bet)
}))
# The subset of graphs where lambda2>0 and has multiplicity >= 2
# numerical accuracy < 10^-12
G7.L2.multi <- Filter(
function(g){
eig <- eigen(graph.laplacian(g))$values
abs(eig[5] - eig[6]) < 1E-12
},
G7
)
# 41 graphs
# The subset of graphs where lambda2>0 and has multiplicity 1
G7.L2.single <- Filter(
function(g){
eig <- eigen(graph.laplacian(g))$values
!(abs(eig[5] - eig[6]) < 1E-12)
},
G7
)
# 483 graphs
# 483 graphs
# Those graphs that have 0-support on at least one vertex for
# every vector in the lambda2-eigenspace
G7.L2.nosupport <- Filter(
function(g){
eigvals <- eigen(graph.laplacian(g))$values
cols <- which(abs(eigvals - eigvals[6]) < 1E-12)
eigvecs <- eigen(graph.laplacian(g))$vectors
eig.L2 <- matrix(eigvecs[, cols], ncol = length(cols))
no.support <- which(rowSums(abs(eig.L2)) < 1E-12)
length(no.support) >= 1
},
G7
)
# 215 graphs
system.time(G8 <- Filter(is.connected, make_all_graphs(8)))
# Without filtering on eigenvalues# user system elapsed
# 42.17 0.14 42.33
# With filtering on eigenvalues
# 19.69 0.02 19.72
# Recommend working with 10pt accuracy to find 'isospectral' graphs
length(G8) # 4156
G8.eigen.adj <- t(sapply(G8, function(g){
eigen(get.adjacency(g))$values
}))
length(which(duplicated(G8.eigen.adj))) # 1
length(which(duplicated(round(G8.eigen.adj, 10)))) # 156
adj.match <- which(duplicated(round(G8.eigen.adj, 10)))
G8.eigen.lap <- t(sapply(G8, function(g){
eigen(graph.laplacian(g))$values
}))
length(which(duplicated(G8.eigen.lap))) # 7
length(which(duplicated(round(G8.eigen.lap, 10)))) # 110
lap.match <- which(duplicated(round(G8.eigen.lap, 10)))
r <- intersect(adj.match, lap.match) # 6 entries
# r[1] = 173
# find graphs that have the same Laplacian and Adjacency spectra:
lapply(r, function(x){
temp <- G8.eigen.lap - matrix(
G8.eigen.lap[x, ],
nrow = nrow(G8.eigen.lap), ncol = 8, byrow = TRUE
)
which(rowSums(temp^2) < 0.001)
})
# [1] 103 173
# [1] 228 309
# [1] 1077 1375
# [1] 2103 2110 # have the same degree distribution as well
# [1] 2676 2678 # have the same degree distrubution as well
# [1] 4004 4005 4073 # 4004/5 have the same degree distribution
# The two graphs 2103 and 2110 have the same eigenvalues (to numerical accuracy) for both Laplacian and Adjacency, have the same degree vector, but have differing betweenness vector. They are non-isomorphic, since one contains K_4, but the other doesn't.
# The eigenvectors differ for the two graphs:
# loadings follow the degree for the leading adjacency eigenvec;
# same values in the eigenvec for alg-connectivity but in different places
betweenness(G8[[2103]])
[1] 9.00 3.00 3.00 0.75 0.75 0.50 0.00 0.00
betweenness(G8[[2110]])
[1] 9.00 1.25 1.25 0.00 2.50 2.50 0.50 0.00
degree(G8[[2103]])
[1] 6 4 4 3 3 3 2 1
round(eigen(get.adjacency(G8[[2103]]))$values, 3)
[1] 3.699 1.363 0.618 0.333 -0.706 -1.618 -1.689
[8] -2.000
round(eigen(graph.laplacian(G8[[2103]]))$values, 4)
[1] 7.0908 5.4142 4.8550 3.6023 2.5858 1.5155 0.9365
[8] 0.0000
# lambda_2 eigenvecs (for 2nd smallest eigenval of Laplacian)
round(eigen(graph.laplacian(G8[[2103]]))$vectors[, 7], 3)
[1] 0.057 -0.182 -0.182 -0.090 -0.090 -0.060 -0.343
[8] 0.891
round(eigen(graph.laplacian(G8[[2110]]))$vectors[, 7], 3)
[1] -0.057 0.090 0.090 0.060 0.182 0.182 0.343
[8] -0.891
# mu_1 eigenvecs (for largest eigenval of adjacency mat)
round(eigen(get.adjacency(G8[[2103]]))$vectors[, 1], 3)
[1] -0.526 -0.401 -0.401 -0.339 -0.339 -0.325 -0.217
[8] -0.142
round(eigen(get.adjacency(G8[[2110]]))$vectors[, 1], 3)
[1] -0.523 -0.431 -0.431 -0.369 -0.296 -0.296 -0.158
[8] -0.139
#######################################################################
# Finding non-isomorphic, connected graphs with the same betweenness distribution is easy:
G8.bet <- t(sapply(G8, function(g) sort(betweenness(g))))
head(which(duplicated(G8.bet)))
[1] 323 547 565 579 632 670
G8.bet[323, ]
with(
list(x = G8.bet - matrix(G8.bet[323, ], nrow = nrow(G8.bet), ncol = 8, byrow = TRUE)),
which(rowSums(x^2) == 0)
)
# 115, 323
###########################################################
# TODO
# Find the smallest pair of connected graphs which have the same:
# graph params:
# a) degree distribution # G5[[4]] and G5[[5]]
# b) diameter # G4[[2]] and G4[[3]]
# c) clique size # G4[[1]] and G4[[2]]
# d) coclique size # G4[[1]] and G4[[2]]
# e) betweenness # G6[[27]] and G6[[34]]
# matrix params:
# f) rank
# g) adjacency eigenvals
# h) laplacian eigenvals
# Find the smallest pair of connected graphs which have the same:
# graph params:
# a) degree distribution # G5[[4]] and G5[[5]]
# b) diameter # G4[[2]] and G4[[3]]
# c) clique size # G4[[1]] and G4[[2]]
# d) coclique size # G4[[1]] and G4[[2]]
# e) betweenness # G6[[27]] and G6[[34]]
# matrix params:
# f) rank
# g) adjacency eigenvals
# h) laplacian eigenvals
No comments:
Post a Comment