Mathematica 9 is now available
Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2011

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Constructing a huge graph

  • To: mathgroup at smc.vnet.net
  • Subject: [mg122118] Re: Constructing a huge graph
  • From: Ray Koopman <koopman at sfu.ca>
  • Date: Sat, 15 Oct 2011 06:02:59 -0400 (EDT)
  • Delivered-to: l-mathgroup@mail-archive0.wolfram.com
  • References: <j76583$2bv$1@smc.vnet.net>

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



  • Prev by Date: A possible typo in the program of "Mathematica Navigator" by Heikki
  • Next by Date: Remark on closing the lernel
  • Previous by thread: Re: Constructing a huge graph
  • Next by thread: Re: Constructing a huge graph