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 Appends

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 Compiled:

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]}]