
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/Bruteforce_search<http://en.wikipedia.org/wiki/Bruteforce_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 kclique 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]*(k1) > > This means: if a[j] is 0, no harm, no foul. If it is 1, then the edges in > the other k1 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 9827266 Business Internet Phone 941 882 0747

