2
$\begingroup$

I am generating a large number of graphs with RandomGraph[SpatialGraphDistribution[n,r]], and parallel mapping a function over them which adds vertices (see the code at the end for the details of addvert), and sets edge weights.

makegraph[nv_, crange_] := Module[{graph},    
graph = addvert[RandomGraph[SpatialGraphDistribution[nv, crange]], 
     fixdverts, crange];    SetProperty[graph, EdgeWeight -> ed[graph]]    ];

I then use

n = RandomVariate[PoissonDistribution[density], Ngraphs];
graphs = ParallelMap[makegraph[#, r0] &, n];

This is using 25 Gigabytes of memory when I have Ngraphs=20,000 and n=2000. It appears that Mathematica is storing every graph it builds, and this whole data structure is somehow worth 25G of memory.

I have tried to generate the graphs one by one, but this stops me using ParallelMap, which is essential for the speed I need here.

I am surprised that these graphs take up that much memory. Am I doing something wrong? Maybe Mathematica can store these graphs more effectively?

ed[rg_] := Module[{ge, el},
   ge = GraphEmbedding[rg];
   el = EdgeList[rg];
   EuclideanDistance @@@ Map[ge[[#]] &, el, {2}]
   ];
addvert[gr_, coord_, range_] := Module[{pts, nl, lv, vv, ee},
  pts = GraphEmbedding[gr];
  vv = VertexList@gr;
  lv = Length@vv;
  nl = lv + # & /@ (Range@Length@coord);
  vv = Join[vv, nl];
  ee = Join[
    Flatten[Thread[# <-> 
         Nearest[Thread[pts -> Range[Length[pts]]], 
          coord[[# - lv]], {Infinity, range}]] & /@ nl], 
    EdgeList@gr];
  Graph[vv, ee, VertexCoordinates -> Join[pts, coord]]
  ]
(*addverts[g_,newverts_,range_]:=Fold[addvert[#,#2,range]&,g,newverts]\
;*)
findT[g_] := Module[{l, lfixd},
   l = Length@VertexList@g;
   lfixd = (Length@fixdverts) - 1;
   GraphDistance[g, l - lfixd, 
      l - #] & /@ (Reverse@Range@(Length@fixdverts - 1) - 1)
   ];
makegraph[nv_, crange_] := Module[{graph},
   graph = 
    addvert[RandomGraph[SpatialGraphDistribution[nv, crange]], 
     fixdverts, crange];
   SetProperty[graph, EdgeWeight -> ed[graph]]
   ];
fixdverts = 
  Developer`ToPackedArray[
   Join[{{.5, .5}}, 
    Table[{.5 + 1/2 Cos[t], .5 + 1/2 Sin[t]}, {t, 0, 2 Pi, Pi/16}]], 
   Real];
T = ConstantArray[0, {400, 2}];
For[i = 100, i <= 102, i++,
  Clear[graphs, n];
  r0 = 1/(5 (1 + i/20)); density = 7/(Pi r0^2); Ngraphs = 2000;
  Print["Starting r0 = ", N@r0, ", Euclidean Distance = ", 
   N@(1/2) (1/r0), ", Density = ", N@density, ", ExpDegree = ", 
   N@(density Pi r0^2)];
  Print[MemoryInUse[]];
  n = RandomVariate[PoissonDistribution[density], Ngraphs];
  graphs = ParallelMap[makegraph[#, r0] &, n];
  Print[Ngraphs, " graphs built!"];
  Print[MemoryInUse[]];
  T[[i, 1]] = N@(1/2) (1/r0);
  T[[i, 2]] = 
   Variance[
    1/r0 DeleteCases[Flatten[ParallelMap[findT, graphs]], Infinity]];
  Print["Variance = ", N@T[[i, 2]]];
  s = OpenAppend["variancedata.txt"];
      Write[s, T[[i, 1]], "", T[[i, 2]]];
      Close[s];
  Print[MemoryInUse[]];
  ];
$\endgroup$
2
$\begingroup$

The graphs produced are that large. One can save a considerable amount of memory and time by avoid Graph in the output. (Graph computes a stores a bunch of potentially superfluous information when it is created. Moreover, UndirectedEdges lead to unpacking of arrays -- a total misconstruction of Graph if you ask me.) In my experiments, this reduced the memory consumption to a sixth of the original value.

Moreover, the routine addvert is rather inefficient for it calls Nearest with the essentially same input over and over again. Finally, the edge weights can be computed immediately without building a graph, so that we can avoid SetProperty.

Edit

I finally managed to get rid of RandomGraph[SpatialGraphDistribution[nv, range]]. This halves the timings for makegraph2. I am not sure though, if my substitute does exactly the same. I also cannot tell what the actual values of the constants MyValueShouldBe1ButItIs2ForCompatibilityReasons and MaybeIShouldHaveTheSameValueAsMyPredecessor should be...

Code

getedges = Compile[{{list, _Integer, 1}},
   Block[{i, j, bag},
    bag = Internal`Bag[Most[{0}]];
    i = Compile`GetElement[list, 1];
    Do[
     j = Compile`GetElement[list, k];
     If[i < j,
      Internal`StuffBag[bag, i];
      Internal`StuffBag[bag, j];
      ],
     {k, 2, Length[list]}];
    Internal`BagPart[bag, All]
    ],
   CompilationTarget -> "C",
   RuntimeAttributes -> {Listable},
   Parallelization -> True,
   RuntimeOptions -> "Speed"
   ];

ToPack = Developer`ToPackedArray;
ClearAll[makegraph2]
makegraph2[nv_, range_, coord_] := Module[{
    pts, newvertices, newedges, edges, alledges, allpts, e1, e2,
    MyValueShouldBe1ButItIs2ForCompatibilityReasons = 2.,
    MaybeIShouldHaveTheSameValueAsMyPredecessor = 1.
    },
   pts = Join[RandomReal[{-1, 1}, {nv, 2}]];
   edges = Partition[Join @@ getedges[
       Nearest[
        pts -> Automatic,
        pts,
        {Infinity, 
         MyValueShouldBe1ButItIs2ForCompatibilityReasons range}
        ]
       ],
     2];
   newvertices = Range[nv + 1, nv + Length[coord]];
   newedges = With[{nearest = Nearest[
        pts -> Automatic,
        coord,
        {Infinity, MaybeIShouldHaveTheSameValueAsMyPredecessor range}
        ]
      }, Transpose[{ToPack[Join @@ (newvertices (1 + 0 nearest))], 
       ToPack[Join @@ nearest]}]
     ];
   alledges = Join[edges, newedges];
   allpts = Join[pts, coord];
   {e1, e2} = Transpose[alledges];
   {
    Range[nv + Length[coord]],
    alledges,
    VertexCoordinates -> allpts,
    EdgeWeight -> 
     Sqrt[Dot[(allpts[[e1]] - allpts[[e2]])^2, ConstantArray[1., 2]]]
    }
   ];

Usage example:

r0 = N[1/(5 (1 + 100/20))];
density = 7/(Pi r0^2);
fixdverts = Join[ConstantArray[0.5, {1, 2}], CirclePoints[{.5, .5}, {0.5, 0.}, 16]];
Ngraphs = 2000;
n = RandomVariate[PoissonDistribution[density], Ngraphs];
graphs = ParallelMap[makegraph2[#, r0, fixdverts] &, n, 
     Method -> "CoarsestGrained"]; // MaxMemoryUsed // AbsoluteTiming

{2.45499, 436102072}

You get an actual Graph, e.g., with Graph@@graphs[[1]].

$\endgroup$
  • 1
    $\begingroup$ You're welcome. Thanks also for the warm words. Your next step would be to optimize out the call RandomGraph if possible. $\endgroup$ – Henrik Schumacher Mar 19 '18 at 16:18
  • 1
    $\begingroup$ Fixed. (ToPack = Developer`ToPackedArray;) $\endgroup$ – Henrik Schumacher Mar 19 '18 at 16:24
  • 1
    $\begingroup$ Nah, I don't think so anymore. I tried to replace RandomGraph by something that builds on pts=RandomReal[{0,1},{1000,2}] and Nearest[pts -> Automatic, pts, {Infinity, range}] (similar as in my answer) and what came out was essentially as fast as RandomGraph (even a bit slower). $\endgroup$ – Henrik Schumacher Mar 19 '18 at 21:42
  • 1
    $\begingroup$ Of course, I cannot be sure. But I have no further ideas, unfortunately. $\endgroup$ – Henrik Schumacher Mar 19 '18 at 21:44
  • 1
    $\begingroup$ Okay, I tried once more. Now makegraph2 is twice as fast as before. $\endgroup$ – Henrik Schumacher Mar 19 '18 at 23:32

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.