[Date Index] [Thread Index] [Author Index]

Re: Finding if a graph G contains any clique of size N...

• To: mathgroup at smc.vnet.net
• Subject: [mg121773] Re: [mg121768] Finding if a graph G contains any clique of size N...
• From: Daniel Lichtblau <danl at wolfram.com>
• Date: Sat, 1 Oct 2011 03:08:32 -0400 (EDT)
• Delivered-to: l-mathgroup@mail-archive0.wolfram.com
• References: <201109300805.EAA06636@smc.vnet.net>

On 09/30/2011 03:05 AM, Richard Palmer wrote:
> A b<http://en.wikipedia.org/wiki/Brute-force_search>rute force algorithm to
> test whether a graph *G* contains a *k*-vertex clique, and to find any such
> clique that it contains, is to examine each subgraph with at least *k* vertices
> and check to see whether it forms a clique. This algorithm takes time O(*n**
> k* *k*2):
>
> Does Mathematica 8 have a straightforward algorithm to implement this that does not involve using the NP hard  FindClique?
>

All such problems are solved either heuristically or via methods that 
handle NP complete problems (which this is). If you want a method that 
is not heuristic but rather guaranteed, best you can hope for is 
something that behaves reasonably well in practice.

This can be cast as an integer linear programming problem. The intent 
behind that is that ILP solvers tend to be reasonably well behaved 
(helps to feed them well and talk in low, soothing tones.

Here is code that takes parameters {n, k, p} where n is the number of 
vertices, k is the size of at least one clique, and p is a probability. 
It generates a random graph with a clique of that size, and probability 
p for all remaining candidate edges.

makeCliqueGraph[n_, k_, p_] :=
  Module[{cverts = RandomSample[Range[n], k], inclique, res},
   Do[inclique[cverts[[j]]] = True, {j, k}];
   res = Table[
     Which[i == j, 0, TrueQ[inclique[i] && inclique[j]], 1, True,
      Boole[RandomReal[] <= p]], {i, n}, {j, n}];
   Clear[inclique];
   res]

To find a k-clique in a graph of n vertices, we set up n variables a[j], 
1<=j<=n, all of which take values 0 or 1. They will sum to k. For each 
row j, we impose the condition that

Sum[a[i]*row[j,i], {i,n}] <= a[j]*(k-1)

This means: if a[j] is 0, no harm, no foul. If it is 1, then the edges 
in the other k-1 positions where a[i] is 1 must all be present. We then 
use NMinimize as a constraint satisfaction tool, wherein the objective 
function is constant and we simply need to find values that meet the 
constraints. Why NMinimize? More below.

findKClique[adjmat_, k_] :=
  Module[{n = Length[adjmat], a, vars, c1, c2, c3, min, vals},
   vars = Array[a, n];
   c1 = Total[vars] == k;
   c2 = Thread[adjmat.vars >= vars*(k - 1)];
   c3 = Map[0 <= # <= 1 &, vars];
   {min, vals} =
    NMinimize[{1, Join[{c1}, c2, c3, {Element[vars, Integers]}]}, vars];
   vars /. vals]

Here we make a graph with 202 vertices, a clique of size 22, and 
probabilities for all other edges of .2.

In[1037]:= gr = makeCliqueGraph[202, 22, .2];

We now find a clique.

In[1038]:= Timing[cl = findKClique[gr, 22]]
Out[1038]= {0.33, {0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
   0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0,
    0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 1,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1,
   0, 0, 0, 0, 0}}

If you are curious as to whether you recover the clique that waws built 
in by design, can do as follows. Modify makeCliqueGraph to return both 
the clique vertices and the graph matrix. Then check whether positions 
of 1's in the clique found by findKClique matches the (sorted) clique 
vertices from the construction step.

makeCliqueGraph[n_, k_, p_] :=
  Module[{cverts = RandomSample[Range[n], k], inclique, res},
   Do[inclique[cverts[[j]]] = True, {j, k}];
   res = Table[
     Which[i == j, 0, TrueQ[inclique[i] && inclique[j]], 1, True,
      Boole[RandomReal[] <= p]], {i, n}, {j, n}];
   Clear[inclique];
   {Sort[cverts], res}]

In[1052]:= {verts, gr} = makeCliqueGraph[202, 22, .2];

In[1053]:= Timing[cl = findKClique[gr, 22];]
Out[1053]= {0.24, Null}

In[1054]:= Position[cl, 1][[All, 1]] === verts
Out[1054]= True

So why use NMinimize? Because it has some fast ILP under the hood. This 
is imperfect in that it relies on interior point code for handling 
relaxed LP problems at machine precision. So it is not fool proof. But 
it tends to be fast.

We might instead use FindInstance. That works with exact LP solvers. 
Bullet proof unless there are bugs, but slower. Here is the modified 
version that uses FindInstance.

findKClique[adjmat_, k_] := Module[
   {n = Length[adjmat], a, vars, c1, c2, c3},
   vars = Array[a, n];
   c1 = Total[vars] == k;
   c2 = Thread[adjmat.vars >= vars*(k - 1)];
   c3 = Map[0 <= # <= 1 &, vars];
   vars /. FindInstance[Join[{c1}, c2, c3], vars, Integers]
   ]

Here is a smaller, but still significant, example.

In[60]:= gr = makeCliqueGraph[101, 11, .1];

In[63]:= Timing[cl = findKClique[gr, 11]]
Out[63]= {217.38, {{0, 1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0,
     0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0}}}

Still much faster than an exhaustive search, I think. I offer the 
computation below in support of that claim.

In[64]:= Binomial[101, 11]
Out[64]= 158940114100040

Daniel Lichtblau
Wolfram Research