Search All of the Math Forum:

Views expressed in these public forums are not endorsed by NCTM or The Math Forum.

Notice: We are no longer accepting new posts, but the forums will continue to be readable.

Topic: Finding if a graph G contains any clique of size N...
Replies: 2   Last Post: Oct 3, 2011 3:51 AM

 Messages: [ Previous | Next ]
 Richard Palmer Posts: 46 Registered: 7/31/06
Re: Finding if a graph G contains any clique of size N...
Posted: Oct 3, 2011 3:51 AM

Thanks Daniel! I will try this.

On Fri, Sep 30, 2011 at 7:12 PM, Daniel Lichtblau <danl@wolfram.com> wrote:

> On 09/30/2011 03:05 AM, Richard Palmer wrote:
>

>> A b<http://en.wikipedia.org/**wiki/Brute-force_search<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.
>
> Module[{n = Length[adjmat], a, vars, c1, c2, c3, min, vals},
> vars = Array[a, n];
> c1 = Total[vars] == k;
> 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.
>
> {n = Length[adjmat], a, vars, c1, c2, c3},
> vars = Array[a, n];
> c1 = Total[vars] == k;
> 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
>

--
Richard Palmer

Home 941 412 8828
Cell 508 982-7266
Business Internet Phone 941 882 0747

Date Subject Author
10/1/11 Daniel Lichtblau
10/3/11 Richard Palmer