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: [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



  • Prev by Date: Re: Limit of nested function
  • Next by Date: Re: find two numbers a,b, such that a+b=5432 & LCM[a,b]=223020
  • Previous by thread: Re: Constructing a huge graph
  • Next by thread: Re: Constructing a huge graph