Re: "set" data structure in Mathematica? (speeding up graph traversal function)
- To: mathgroup at smc.vnet.net
- Subject: [mg117633] Re: "set" data structure in Mathematica? (speeding up graph traversal function)
- From: DrMajorBob <btreat1 at austin.rr.com>
- Date: Tue, 29 Mar 2011 06:50:37 -0500 (EST)
Here's a solution using Sow and Reap:
Clear[traverse6]
Timing[
nodes = Union@Flatten[graph /. Rule -> List];
dg = Dispatch@graph;
links = ReplaceList[#, dg] & /@ nodes;
traverse6[path_][node_] /; MemberQ[path, node] = Null;
traverse6[{path___}][node_] :=
With[{p = {path, node}, next = links[[node]]},
If[next == {}, Sow@p, traverse5[p] /@ next
]];
Print@Timing[u5 = First@Last@Reap[traverse6[{}] /@ nodes];];
Length /@ (u5 = GatherBy[u5, First])
]
{0.880847,Null}
{0.912256, {1, 1, 1, 1, 2, 3, 4, 7, 10, 8, 7, 7, 7, 10, 15, 15, 32,
394, 355, 396, 863, 820, 1225, 891, 1211, 827, 11269, 13353, 15430}}
Bobby
On Sat, 26 Mar 2011 17:47:08 -0500, DrMajorBob <btreat1 at austin.rr.com>
wrote:
> Here's a solution in Ray's format, twice as fast:
>
> Clear[traverse3]
> Timing[
> nodes = Union@Flatten[graph /. Rule -> List];
> sources = Union@graph[[All, 1]];
> links = ReplaceList[#, Dispatch@graph] & /@ nodes;
> (traverse3[path_][#] := List@Append[path, #]) & /@
> Complement[nodes, sources];
> traverse3[path_][node_] /; MemberQ[path, node] = {};
> traverse3[path_][node_] :=
> Join @@ (traverse3[Append[path, node]] /@ links[[node]]);
> Length /@ (u3 = traverse3[{}] /@ nodes)
> ]
>
> {0.46727, {1, 1, 1, 1, 2, 3, 4, 7, 10, 8, 7, 7, 7, 10, 15, 15, 32,
> 394, 355, 396, 863, 820, 1225, 891, 1211, 827, 11269, 13353, 15430}}
>
> Timing[
> traverse2[L_][path_][node_] :=
> With[{p = Append[path, node]},
> Which[L[[node]] === {}, {p},
> MemberQ[path, node], {},
> True, Join @@ (traverse2[L][p] /@ L[[node]])
> ]
> ];
> m = Max[graph /. Rule -> List];
> links = ReplaceList[#, graph] & /@ Range@m;
> Length /@ (u2 = traverse2[links][{}] /@ Range@m)]
>
> {0.92439, {1, 1, 1, 1, 2, 3, 4, 7, 10, 8, 7, 7, 7, 10, 15, 15, 32,
> 394, 355, 396, 863, 820, 1225, 891, 1211, 827, 11269, 13353, 15430}}
>
> u2 == u3
>
> True
>
> .92439/.46727
>
> 1.97828
>
> The following seemed promising but wasn't as good as traverse3:
>
> Clear[traverse4]
> Timing[
> nodes = Union@Flatten[graph /. Rule -> List];
> sources = Union@graph[[All, 1]];
> links = ReplaceList[#, Dispatch@graph] & /@ nodes;
> (traverse4[path_][#] := List@Append[path, #]) & /@
> Complement[nodes, sources];
> traverse4[path_][node_] /; MemberQ[path, node] = {};
> traverse4[path_][node_] := With[{p = Append[path, node]},
> Join @@ (traverse4[p] /@ Complement[links[[node]], p])];
> Length /@ (u4 = traverse4[{}] /@ nodes)
> ]
>
> {0.762191, {1, 1, 1, 1, 2, 3, 4, 7, 10, 8, 7, 7, 7, 10, 15, 15, 32,
> 394, 355, 396, 863, 820, 1225, 891, 1211, 827, 11269, 13353, 15430}}
>
> u2 == u3 == u4
>
> True
>
> Bobby
>
> On Sat, 26 Mar 2011 04:49:43 -0500, Ray Koopman <koopman at sfu.ca> wrote:
>
>> I read this group on Google and it's been almost 48 hours since the
>> last posts appeared, so please excuse me if I've missed something.
>>
>> First, some results from Szabolc's original routine:
>>
>> Timing[Length /@ (u = traverse[graph][{}] /@ Range@m)]
>>
>> {17.29 Second, {1, 1, 1, 1, 2, 3, 4, 7, 10, 8, 7, 7, 7, 10, 15, 15,
>> 32, 394, 355, 396, 863, 820, 1225, 891, 1211, 827, 11269, 13353, 15430}}
>>
>> Here's a routine that gives the same output in much less time.
>> It does only two things differerntly: it gets a major speedup by
>> preprocessing graph into lists of links, and a very minor speedup
>> by changing the nested If's to a single Which. I tried several ways
>> to eliminate MemberQ, but none of them helped.
>>
>> traverse2[L_][path_][node_] :=
>> With[{p = Append[path, node]},
>> Which[
>> L[[node]] === {} , {p},
>> MemberQ[path, node], {},
>> True , Join @@ (traverse2[L][p] /@ L[[node]])
>> ]
>> ]
>>
>> m = Max[graph/.Rule->List];
>> links = ReplaceList[#,graph]&/@Range@m];
>>
>> Timing[Length /@ (u2 = traverse2[links][{}] /@ Range@m)]
>> u2 == u
>>
>> {2.45 Second, {1, 1, 1, 1, 2, 3, 4, 7, 10, 8, 7, 7, 7, 10, 15, 15,
>> 32, 394, 355, 396, 863, 820, 1225, 891, 1211, 827, 11269, 13353, 15430}}
>> True
>>
>> The routines in Bobby's last two posts are slower,
>> and their results differ from Szabolcs' and mine.
>>
>> Clear[next, path, p]
>> d = Dispatch@graph;
>> nodes = Union@Flatten[graph /. Rule -> List];
>> next[i_Integer] := next[i] = ReplaceList[i, d]
>> path[i_Integer] := path@p@i
>> path[p[a___, last_]] :=
>> Module[{c = Complement[next@last, {a, last}]},
>> If[c == {}, p[a, last], path@p[a, last, #] & /@ c]]
>> (paths = (path /@ nodes); Length@Flatten@paths) // Timing
>>
>> {3.73 Second,47165}
>>
>> Clear[next, path, p]
>> nodes = Union@Flatten[graph /. Rule -> List];
>> next[i_Integer] := next[i] = Cases[graph, Rule[i, j_] :> j]
>> path[i_Integer] := path@p@i
>> path[p[a___, last_]] :=
>> Module[{c = Complement[next@last, {a, last}]},
>> If[c == {},
>> p[a, last],
>> Flatten[path@p[a, last, #] & /@ c]
>> ]
>> ]
>> (paths2 = (path /@ nodes); Length@Flatten@paths2) // Timing
>>
>> {4.29 Second, 47165}
>>
>> paths == paths2
>> Flatten@paths == Flatten@paths2
>>
>> False
>> True
>>
>> Besides having a 'p' head on each path,
>> singleton paths are given as scalars.
>> Here are the first 5 rows:
>>
>> Take[u,5]
>> Flatten/@Take[paths,5]/.p->List
>>
>> {{{1,2}},{{2}},{{3,4}},{{4}},{{5,1,2},{5,2}}}
>> {{{1,2}}, {2} ,{{3,4}}, {4} ,{{5,1,2},{5,2}}}
>
>
--
DrMajorBob at yahoo.com