Re: Constructing a huge graph

*To*: mathgroup at smc.vnet.net*Subject*: [mg122160] Re: Constructing a huge graph*From*: Jaebum Jung <jaebum at wolfram.com>*Date*: Mon, 17 Oct 2011 08:09:39 -0400 (EDT)*Delivered-to*: l-mathgroup@mail-archive0.wolfram.com

What you want construct is complete graph. Here's another way to do it. 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]]; construct weights: weights = Developer`ToPackedArray[ Flatten[ParallelTable[ weightC[coords[[i]], coords[[j]]], {i, 1, len - 1}, {j, i + 1, len}]]]; define complete graph with weights: g = CompleteGraph[len, EdgeWeight -> weights]; In[10]:= GraphDistance[g, start, end] // Timing Out[10]= {0.349667, 24.} In[11]:= FindShortestPath[g, start, end] // Timing Out[11]= {0.375186, {299, 945, 216, 621, 659, 674, 1252, 855, 1224, 305, 1162, 1341, 127, 113, 947, 1337}} - Jaebum ----- Original Message ----- From: "Ray Koopman" <koopman at sfu.ca> To: mathgroup at smc.vnet.net Sent: Saturday, October 15, 2011 5:02:59 AM Subject: [mg122160] Re: Constructing a huge graph On Oct 13, 12:50 am, Martin <mfpub... at gmail.com> 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. This uses Daniel's data, weight function, and algorithm. However, it was run on an old machine using v5.2, so I've "cheated" on the problem and used a matrix of edge weights. Converting to function calls for the weights should not be too hard. n = Length@coords {start,end} = {299, 1337} {x,y} = Transpose@xy; (w = Table[Abs[(x[[j]]-x[[k]])^2 - .1 Abs[y[[j]]-y[[k]]]], {j,n},{k,n}])[[start,end]] 1500 {299,1337} 3333.6 This gets only the distance. Timing@Part[FixedPoint[Table[Min[#[[j]],Min[#+w[[j]]]],{j,n}]&, w[[start]], n], end] {78.5 Second,24.} Do we get the same distance when we swap start and end? Timing@Part[FixedPoint[Table[Min[#[[j]],Min[#+w[[j]]]],{j,n}]&, w[[end]], n], start] {75.48 Second,24.} These are slower but give the path as well as the distance. Timing@Part[Transpose@FixedPoint[Transpose@Table[ t = #[[1]] + w[[j]]; k = First@Ordering[t,1]; If[#[[1,j]] <= t[[k]], {#[[1,j]],#[[2,j]]}, {t[[k]],Append[#[[2,k]],j]}],{j,n}]&, {w[[start]],Array[{start,#}&,n]}, n], end] {106.21 Second,{24.,{299,945,216,621,659,674,1252,855, 1224,305,1162,1341,127,113,947,1337}}} Timing@Part[Transpose@FixedPoint[Transpose@Table[ t = #[[1]] + w[[j]]; k = First@Ordering[t,1]; If[#[[1,j]] <= t[[k]], {#[[1,j]],#[[2,j]]}, {t[[k]],Append[#[[2,k]],j]}],{j,n}]&, {w[[end]],Array[{end,#}&,n]}, n], start] {101.42 Second,{24.,{1337,947,113,127,1341,1162,305,1224, 855,1252,674,659,621,216,945,299}}}