Optimization of a graph generator algorithm
One issue is the creation and part extraction of new graphs at every step. Another is that parallelizing might not be useful in this situation since the operations are fast, there are not many to be done in each step, and the data transfer cost might thus dwarf the actual iteration.
The code below seems to produce identical results. At least they look similar. I have not made IsomorphicGraphQ
behave well enough to be sure though.
model2[n_, m_, r_, p_] /; n >= 3 := Module[
{g, vdeg, el, el2, node, newnode},
g = ConstantArray[{}, n];
g[[1 ;; m + 1]] = Table[Delete[Range[m + 1], j], {j, m + 1}];
vdeg = ConstantArray[0, n];
vdeg[[1 ;; m + 1]] = m;
Do[
If[RandomReal[] <= p,
node = RandomChoice[vdeg[[1 ;; j - 1]]^r -> Range[j - 1]];
g[[j]] = g[[node]];
vdeg[[j]] = vdeg[[node]];
Do[vdeg[[k]] += 1; g[[k]] = Append[g[[k]], j], {k, g[[node]]}];
,
node = RandomSample[vdeg[[1 ;; j - 1]] -> Range[j - 1], m];
g[[j]] = node;
vdeg[[j]] = m;
Do[vdeg[[k]] += 1; g[[k]] = Append[g[[k]], j], {k, node}]
];
, {j, m + 2, n}];
Graph[Union[
Map[Sort, Flatten[MapIndexed[Thread[{#2[[1]], #1}] &, g], 1]]]]
]
At n=1000
the original takes 87 seconds on my laptop. The variant above takes 2.5 seconds. I still am not thrilled with the quadratic+ complexity caused (mostly) by the use of Append
. Might be room for more improvement there.
Here's an adaptation of Daniel Lichtblau's version:
modelGraph[g_] :=
Graph[
Union[
Map[Sort,
Flatten[MapIndexed[Thread[{#2[[1]], #1}] &, g], 1]
]
]
];
model3Core[n_, m_, r_, p_] :=
Module[{g, vdeg, el, el2, node, nodelist, newnode,
sampPadding = Table[0, {i, n}]
},
g =
With[{base = Table[0, {i, m + n}]},
Table[base, n]
];
Do[
With[{l = Delete[Range[m + 1], j]},
g[[j, 1]] = Length@l;
g[[j, 2 ;; Length@l + 1]] = l;
],
{j, m + 1}
];
vdeg = Table[0, {i, n + m}];
Do[vdeg[[i]] = m, {i, m + 1}];
Do[
If[RandomReal[] <= p,
node = RandomChoice[vdeg[[1 ;; j - 1]]^r -> Range[j - 1]];
g[[j]] = g[[node]];
vdeg[[j]] = vdeg[[node]];
Do[
With[{k = g[[node, k]]},
vdeg[[k]] += 1;
g[[k, vdeg[[k]] ]] = j;
],
{k, vdeg[[node]]}
];,
nodelist = RandomSample[vdeg[[1 ;; j - 1]] -> Range[j - 1], m];
g[[j]] = Join[nodelist, sampPadding];
vdeg[[j]] = m;
Do[
vdeg[[k]] += 1;
g[[k, vdeg[[k]] ]] = j;,
{k, nodelist}
]
];,
{j, m + 2, n}
];
Append[g, vdeg]
];
model3[n_, m_, r_, p_] /; n >= 3 :=
MapThread[Take, {Most@#, Drop[Last@#, -m]}] &@
model3Core[n, m, r, p]
All I did really was remove the Append
s
If we redefine model2
to remove the Graph
call we can directly compare them:
Map[
First@AbsoluteTiming@model2[#, 5, 1, .5] &,
{100, 1000, 5000}
]
{0.009174, 0.405928, 12.1925}
Map[
First@AbsoluteTiming@model3[#, 5, 1, .5] &,
{100, 1000, 5000}
]
{0.010279, 0.627182, 20.7768}
And... somehow I made it worse.
But my version can be Compile
d:
model3Comp =
With[{t = Extract[DownValues[model3Core], {1, 2}, Unevaluated]},
Compile @@ Hold[{
{n, _Integer},
{m, _Integer},
{r, _Real},
{p, _Real}
},
t
]
];
model3c[n_, m_, r_, p_] /; n >= 3 :=
MapThread[Take, {Most@#, Drop[Last@#, -m]}] &@
model3Comp[n, m, r, p]
Map[
First@AbsoluteTiming@model3c[#, 5, 1, .5] &,
{100, 1000, 5000}
]
{0.0009, 0.048616, 1.32722}
And that brings us into a good domain to work with.
Now we can do the real call in reasonable time:
model3c[11711, 5, 1, .5] // AbsoluteTiming // First
10.096
And just to check that it lines up on a smaller system:
GraphicsRow@
Map[Rasterize@*modelGraph, {model2[50, 5, 1, .5],
model3c[50, 5, 1, .5]}]