# Using less memory with ParallelMap when modifying random geometric graphs

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},
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[
coord[[# - lv]], {Infinity, range}]] & /@ nl],
EdgeList@gr];
Graph[vv, ee, VertexCoordinates -> Join[pts, coord]]
]
;*)
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 =
fixdverts, crange];
SetProperty[graph, EdgeWeight -> ed[graph]]
];
fixdverts =
DeveloperToPackedArray[
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[]];
];


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 = InternalBag[Most[{0}]];
i = CompileGetElement[list, 1];
Do[
j = CompileGetElement[list, k];
If[i < j,
InternalStuffBag[bag, i];
InternalStuffBag[bag, j];
],
{k, 2, Length[list]}];
InternalBagPart[bag, All]
],
CompilationTarget -> "C",
RuntimeAttributes -> {Listable},
Parallelization -> True,
RuntimeOptions -> "Speed"
];

ToPack = DeveloperToPackedArray;
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]].

• You're welcome. Thanks also for the warm words. Your next step would be to optimize out the call RandomGraph if possible. Mar 19, 2018 at 16:18
• Fixed. (ToPack = DeveloperToPackedArray;) Mar 19, 2018 at 16:24
• 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). Mar 19, 2018 at 21:42
• Of course, I cannot be sure. But I have no further ideas, unfortunately. Mar 19, 2018 at 21:44
• Okay, I tried once more. Now makegraph2` is twice as fast as before. Mar 19, 2018 at 23:32