5
$\begingroup$

Is there a way by which Mathematica can be given a graph as an input and be asked to find its expansion?

Note: By "expansion" I mean the quantity called "isoperimetric number" or "Cheeger constant", $h(G)$ here , http://en.wikipedia.org/wiki/Expander_graph

PS: A naive way to do this is to somehow be able to just run through all possible subsets of the vertex set of a graph and find those that minimize $h(G)$. Is there any way to even implement this on Mathematica?

Since computing $h(G)$ is anyway known to be NP-Hard, I don't expect any dramatically fast way to exist than the above naive thing. But it would still help if some optimized inbuilt implementation exists.

$\endgroup$
  • 1
    $\begingroup$ @belisarius I have added references in the question. $\endgroup$ – user6818 Sep 18 '14 at 5:21
  • $\begingroup$ According to the online documentation, there is a GraphData property called "CheegerConstant" that should work with the usual syntax: GraphData[g,"CheegerConstant"]. However, this doesn't seem to work (even the documentation contains errors as output). reference.wolfram.com/language/ref/GraphData.html $\endgroup$ – Kellen Myers Sep 19 '14 at 3:52
6
$\begingroup$

You can use memoization and some other ideas to speed this up.

Clear[Mat, d, g];
Mat[G_] := Normal[AdjacencyMatrix[G]];
d[s1_, s2_, G_] := d[s1, s2, G] = If[s1 == {} || s2 == {}, 0,
    If[Length[s1] > VertexCount[G]/2, d[s2, s1, G],
     d[Rest[s1], s2, G] + Plus @@ Mat[G][[s1[[1]], s2]]
     (* This takes s1 excluding its first element and computes that value
        and then adds however many edges (adding up 1s in the adjacency
        matrix) go from the first element of s1 to the rest of s2. *)
     ]
    ];
(* d(s1,s2,G) computes the number of edges between s1 and s2, vertex sets
    in the graph G. It does this recursively, not assuming s1 and s2 are
    complements in G, and remembers its values aka. memoization. *)
g[G_] := Module[{
    M = Mat[G],
    hval = \[Infinity],
    dval, i, j, s},
   For[i = 1, i < 2^Length[M], i++,
    s = Transpose[Position[IntegerDigits[i, 2, Length[M]], 1]][[1]];
    (* s uses binary digits of i to determine each subset of M *)
    If[Length[s] <= Length[M]/2,
     dval = d[Complement[Range[Length[M]], s], s, G]/Length[s];
     If[dval < hval, hval = dval];
     (* This just updates the output hval if the new possible value is less *)
     ];
    ];
   Return[hval];
   ];

This will give you speeds faster than what is given by belisarius. It will eat up memory pretty quickly for large graphs, but since the function d remembers itself, this winds up being a bit faster. You can compare to the f function by belisarius to get:

Timing[g /@ {CompleteGraph@6, CycleGraph@6}]
Timing[f /@ {CompleteGraph@6, CycleGraph@6}]
%[[2]] == %%[[2]]
Timing[g /@ {CompleteGraph@10, CycleGraph@10}]
Timing[f /@ {CompleteGraph@10, CycleGraph@10}]
%[[2]] == %%[[2]]

(* Output:
{0.046800, {3, 2/3}}
{0.171601, {3, 2/3}}
True
{0.670804, {5, 2/5}}
{4.009226, {5, 2/5}}
True
*)

You can verify that they agree on a few random graphs:

TESTSET = RandomGraph[
   {n = RandomInteger[{5, 12}],
    RandomInteger[{Ceiling[n^2/8], Floor[n^2/2.5]}]},
   15];
Timing[g /@ TESTSET]
Timing[f /@ TESTSET]
%[[2]] == %%[[2]]

(* Output:
{0.436803, {0, 2/3, 1/3, 1/2, 0, 0, 0, 1/2, 0, 1/2, 0, 1/2, 0, 0, 0}}
{3.088820, {0, 2/3, 1/3, 1/2, 0, 0, 0, 1/2, 0, 1/2, 0, 1/2, 0, 0, 0}}
*)

We can do a couple more random ones to see the time difference grow:

TESTSET = RandomGraph[
   {n = RandomInteger[{10, 15}],
    RandomInteger[{Ceiling[n^2/8], Floor[n^2/2.5]}]},
   2];
Timing[g /@ TESTSET]
Timing[f /@ TESTSET]
%[[2]] == %%[[2]]

(* Output:
{0.670804, {8/5, 7/5}}
{6.302440, {8/5, 7/5}}
True
*)

And in general, you get some improvement:

comparison timing scatter plot

Of course, in the end, you still get problems that take too long -- this is still a hard problem. But I think this algorithm is a bit faster and will work with slightly larger graphs (memory will help with that too -- not sure how belisarius's algorithm hits the RAM).

$\endgroup$
  • $\begingroup$ I am unable to understand your code. I simply don't know enough Mathematica to parse your code. How do I even give the graph as an input to your code? What is "Plus @@", "Rest", "Module" , "IntegerDigits", "Position", "[Infinity]", "Complement", "Range" - none of these make any sense to me! Can you kindly write something for beginners? $\endgroup$ – user6818 Sep 20 '14 at 5:05
  • $\begingroup$ May be you can add some explanations to your code? $\endgroup$ – user6818 Sep 20 '14 at 5:19
  • $\begingroup$ I have added a few comments. I am not sure I can provide in-depth explanations for built-in functions like Rest, but whatever I say wouldn't be as good as the on-line help you can get in Mathematica anyway (documentation that is mirrored on Wolfram's support/documentation website). $\endgroup$ – Kellen Myers Sep 20 '14 at 18:37
6
$\begingroup$

This is the exact calculation. Don't try it with large Graphs:

f[g_] := Min[
     (Length@ Complement[Sort /@ EdgeList[NeighborhoodGraph[EdgeDelete[g, UndirectedEdge[a_, b_] /; 
                                                           Nor[MemberQ[#, a], MemberQ[#, b]]], #]], 
                         Sort /@ EdgeList[Subgraph[g, #]]] / 
      Length@#) & /@  
                     (Subsets[#, {1, IntegerPart[Length[#]/2]}] &@ VertexList[g])]

f /@ {CompleteGraph@6, CycleGraph@6}

This returns the exact theoretical result for both graphs n/2 and 4/n:

(* {3, 2/3} *)

And this is why you shouldn't try it with large graphs. Look at the number of evals vs. graph size:

ListLogPlot@ Table[Length@(Subsets[#, {1, IntegerPart[Length[#]/2]}] &@  Range@x), {x, 20}]

Mathematica graphics


The following is an approximation (but runs much faster):

f[g_] := Min[ N@(Length@
       Complement[ Sort /@ EdgeList[ NeighborhoodGraph[EdgeDelete[g, UndirectedEdge[a_, b_] /; 
             Nor[MemberQ[#, a], MemberQ[#, b]], #]], 
        Sort /@ EdgeList[Subgraph[g, #]]]/Length@#) & /@  FindGraphPartition[g]]

f /@ {CompleteGraph@20, CycleGraph@20}
(* {9., 0.2} *)

While the theoretical values are {10, .2}

$\endgroup$
  • $\begingroup$ Does this give the exact value of $h(G)$ or an approximation? $\endgroup$ – user6818 Sep 18 '14 at 14:40
  • $\begingroup$ Can you just tell me how to run though all possible subsets of vertices of some input graph and calculate the RHS of h(G) for each of them? $\endgroup$ – user6818 Sep 18 '14 at 14:41
  • $\begingroup$ Given my purposes I am not sure that it will be useful for me to get approximations. I think I need exact values. $\endgroup$ – user6818 Sep 18 '14 at 14:43

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.