[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
Prev by Date:
**Re: Re: ParallelDo and C-compiled routines**
Next by Date:
**Re: ParallelDo and C-compiled routines**
Previous by thread:
**Re: ParallelDo and C-compiled routines**
Next by thread:
**Re: Finding if a graph G contains any clique of size N...**
| |