MathGroup Archive 2011

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

Search the Archive

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

  • To: mathgroup at smc.vnet.net
  • Subject: [mg121810] Re: Finding if a graph G contains any clique of size N...
  • From: Richard Palmer <rhpalmer at gmail.com>
  • Date: Mon, 3 Oct 2011 04:22:59 -0400 (EDT)
  • Delivered-to: l-mathgroup@mail-archive0.wolfram.com
  • References: <201109300805.EAA06636@smc.vnet.net>

Thanks Daniel!  I will try this.

On Fri, Sep 30, 2011 at 7:12 PM, Daniel Lichtblau <danl at 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.
>
> 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
>



-- 
Richard Palmer

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



  • Prev by Date: Re: ParallelDo and C-compiled routines
  • Next by Date: Re: ParallelDo and C-compiled routines
  • Previous by thread: Re: Finding if a graph G contains any clique of size N...
  • Next by thread: count zeros in a number