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