Re: Constructing a huge graph

*To*: mathgroup at smc.vnet.net*Subject*: [mg122166] Re: Constructing a huge graph*From*: DrMajorBob <btreat1 at austin.rr.com>*Date*: Tue, 18 Oct 2011 07:40:19 -0400 (EDT)*Delivered-to*: l-mathgroup@mail-archive0.wolfram.com*References*: <201110130747.DAA02343@smc.vnet.net>*Reply-to*: drmajorbob at yahoo.com

Here's an alternative that minimizes scans and returns a shortest path for Daniel's data. I removed duplicates from "coords", but it hardly mattered, as there was only one. len = 1500; SeedRandom[1111]; coords = RandomInteger[{1000}, {len, 2}]; {start, end} = RandomChoice[Range[len], 2] first = coords[[start]]; last = coords[[end]]; unsortedUnion = Tally[#][[All, 1]] &; coords = unsortedUnion@coords; Clear[weight, dist, pred] weight[{x1_, y1_}, {x2_, y2_}] = Abs[(x1 - x2)^2 - Abs[y1 - y2]/10]; dist[first] = 0; dist[_] = Infinity; pred[0] = 0; pred[_] = 0; scan = {first}; reap = {Null}; Print@Timing@{Length@coords, dist@last} Timing@While[Length@reap > 0, Print@Timing[reap = Last@Reap@Do[ dist@old < dist@last && Do[ dist@new > (d = dist@old + weight[new, old]) && (dist[new] = d; pred[new] = old; d < dist@last) && Sow@new, {new, DeleteCases[coords, old]}], {old, scan}]; If[Length@reap > 0, {Length@(scan = Union@First@reap), N@dist@last}, {0, N@dist@last}]]] {dist@last, Reverse@FixedPointList[pred, last][[;; -3]]} {299, 1337} {0.000016,{1499,\[Infinity]}} {0.035342,{1353,3333.6}} {4.24568,{241,27.}} {2.26133,{46,24.}} {0.716256,{26,24.}} {0.460818,{21,24.}} {0.375759,{12,24.}} {0.216024,{12,24.}} {0.214408,{14,24.}} {0.252448,{6,24.}} {0.112929,{3,24.}} {0.056949,{1,24.}} {0.021414,{0,24.}} {8.97056, Null} {24, {{258, 38}, {263, 255}, {267, 394}, {273, 21}, {278, 263}, {282, 102}, {285, 168}, {293, 842}, {299, 476}, {301, 531}, {302, 498}, {308, 862}, {314, 511}, {312, 441}, {313, 448}, {316, 342}}} Bobby On Fri, 14 Oct 2011 04:52:53 -0500, Daniel Lichtblau <danl at wolfram.com> wrote: > On 10/13/2011 02:47 AM, Martin wrote: >> Hi >> >> I am currently trying to construct a very large weighted graph but I >> find myself in huge troubles :-). I simply lack the experience in >> Mathematica to figure out how to get around the issue below. >> >> The data: I have a large number of points, more specifically> 15 000 >> pairs of integer coordinates (x, y) in a list. >> >> The aim: Construct a weighted (undirected) graph with an edge between >> any two points (so the total number of edges is more than Binomial[15 >> 000, 2] -- quite a lot). The point is that I want to find a shortest >> path between two specific vertices. >> >> The code: I have written looks like this: >> GraphDistance[ >> (Graph[ >> #1, (* the edges *) >> EdgeWeight -> First[#2]]&) @@ >> Reap[ >> (Module[{}, >> Sow[weight @@ #]; (* compute weight *) >> UndirectedEdge @@ # (* make edge *) >> ]&) /@ Subsets[coords,{2}], >> startP, >> targetP, >> Method --> "Dijkstra" (* weights are>= 0 *) >> ] >> >> The problem: The code is sooo slow - even for 5000 points :-), and >> Mathematica (for Students) aborts the computation because of >> "insufficient memory" already when I have 10000 points. >> >> Help: I have tried to look through a number of ressources on the >> internet but I have to admit that all the different pieces of advice >> on how to construct efficient code is a bit overwhelming for me as an >> inexperienced Mathematica programmer. >> I believe that it should be possible to get a reasonably efficient >> code for the above problem, but I do not know how to accomplish that. >> >> My own thoughts: First of all, the Subsets function constructs a huge >> list, and afterwards I use Map, to get two lists that are used for the >> Graph object - I believe this is where the problem is. >> I guess that, if I could produce my own subsets function where I would >> be able to compute the weight directly on each pair of points (x,y), >> and then put it directly in a SparseArray, could reduce both time, and >> memory consumption?? >> >> I hope that you can maybe point me in the right direction, or have any >> specific advice for my particular graph problem :-). >> >> Thanks in advance. > > With 112492500 edges this graph is unlikely to fit in the RAM of a 32 > bit machine. I do not know if Mathematica 8 on 64 bit machines will > handle it either (nor do I know for Mathematica 9). > > If you have a simple function that gives the edge weight, given a pair > of vertices, then you can use a sparse strategy, keeping only a vector > or two at any time rather than a full matrix. > > One way go about this by explicit iteration. Keep a vector of shortest > distances from start to all points that can be attained via n or fewer > hops, and using Min, and distances from each to others in one hop, to > get same for n+1 or fewer hops. > > Here is pedestrian code for this purpose. I douvbt it is optimal, even > with use of Compile to C code. (I also do not claim that it is correct-- > caveat emptor). > > I use an example consisting of (only) 1500 vertices. The weight function > is described as: > > weight[{x1_, y1_}, {x2_, y2_}] := > Sqrt[(N[(x1 - x2)]^2 - Abs[y2 - y1]/10.)^2] > > len = 1500; > SeedRandom[1111]; > coords = N[RandomInteger[{1000}, {len, 2}]]; > {start, end} = RandomChoice[Range[len], 2] > weightC = > Compile[{{p1, _Real, 1}, {p2, _Real, 1}}, > Sqrt[((p1[[1]] - p2[[1]])^2 - Abs[p1[[2]] - p2[[2]]]/10.)^2]]; > v1 = weightC[coords[[start]], #] & /@ coords; > mindistC = Compile[{{d1, _Real, 1}, {coords, _Real, 2}}, > Table[Min[d1[[j]], > Min[Table[ > d1[[k]] + weightC[coords[[k]], coords[[j]]], {k, > Length[coords]}]]], {j, Length[d1]}], > CompilationOptions -> {"ExpressionOptimization" -> True, > "InlineExternalDefinitions" -> True, > "InlineCompiledFunctions" -> True}, CompilationTarget -> "C"]; > Timing[FixedPoint[mindistC[#, coords] &, v1, Length[coords]][[end]]] > > Out[555]= {299, 1337} > Out[559]= {24.13, 24.} > > So the min distance from vertex 299 to 1337 is 24 units. > > Getting the minimal path would take more work. > > Daniel Lichtblau > Wolfram Research > -- DrMajorBob at yahoo.com

**References**:**Constructing a huge graph***From:*Martin <mfpublic@gmail.com>

**Re: Limit of nested function**

**Re: find two numbers a,b, such that a+b=5432 & LCM[a,b]=223020**

**Re: Constructing a huge graph**

**Re: Constructing a huge graph**