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