       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;
coords = N[RandomInteger[{1000}, {len, 2}]];
{start, end} = RandomChoice[Range[len], 2]
weightC =
Compile[{{p1, _Real, 1}, {p2, _Real, 1}},
Sqrt[((p1[] - p2[])^2 - Abs[p1[] - p2[]]/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:= GraphDistance[g, start, end] // Timing

Out= {0.349667, 24.}

In:= FindShortestPath[g, start, end] // Timing

Out= {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 :-).
>

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 = #[] + 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 = #[] + 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}}}

```

• Prev by Date: Re: find two numbers a,b, such that a+b=5432 & LCM[a,b]=223020
• Next by Date: Re: Formatting in XLS(X) files
• Previous by thread: Re: Constructing a huge graph
• Next by thread: Need Help with understanding line of code ( and what a certain placement of a comma means) Thanks VB.net and Mathmatica help ?