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];
>
> 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

```

• Prev by Date: Re: Writing images from manipulate
• Next by Date: Re: Importing into Mathematica from URL (PubMed)
• Previous by thread: Re: "set" data structure in Mathematica? (speeding up graph traversal function)
• Next by thread: Re: "set" data structure in Mathematica? (speeding up graph traversal function)