Re: "set" data structure in Mathematica? (speeding up graph traversal function)
- To: mathgroup at smc.vnet.net
- Subject: [mg117638] Re: "set" data structure in Mathematica? (speeding up graph traversal function)
- From: DrMajorBob <btreat1 at austin.rr.com>
- Date: Tue, 29 Mar 2011 06:51:31 -0500 (EST)
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