Re: aggregation of related elements in a list
- To: mathgroup at smc.vnet.net
- Subject: [mg61889] Re: [mg61542] aggregation of related elements in a list
- From: "Carl K. Woll" <carl at woll2woll.com>
- Date: Thu, 3 Nov 2005 04:59:04 -0500 (EST)
- References: <200510220435.AAA06197@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
leigh pascoe wrote:
> Dear Mathgroup,
>
> I would like to construct a function to transform a list of integers
> into a list of lists of related members. Suppose we have the finite list
>
> {x1,x2,x3,..........xN}
>
> and a test function ( relatedQ[x_,y_,n_] ) that decides whether two
> elements are related. The actual test may vary, but returns True or
> False for any two elements as a function of n (n is an independent
> variable not the number of elements in the list}.
>
> I would like to process this list to aggregate those members that are
> related either directly to each other or to a common element. For
> example if x1 is unrelated to any other element in the list, x2 is
> related to x5 but not x7 and x5 is related to x7 etc. would produce the
> list of lists
>
[snip]
Not to beat a dead horse here, but I uncovered an internal function
which greatly speeds up the process of finding the connected components.
Here is the new function:
aggs[n_, pairs_] := Module[{sp, t},
sp = SparseArray[Thread[pairs -> 1], {n, n}];
t = Sign[sp + Transpose[sp]];
SparseArray`StronglyConnectedComponents[t]]
For reference, some of the old functions (my agg, maxim's agg3,
lichtblau's aggregate) are given at the end of my post. Note that I
fixed up my agg function so that it would work properly in version 5.2.
At any rate, here is some data:
n = 10^4;
pairs = Table[Random[Integer, {1, n}], {n}, {2}];
In[10]:=
r1=aggs[n,pairs];//Timing
r2=agg3[n,pairs];//Timing
r3=aggregate[n,pairs];//Timing
r4=agg[n,pairs];//Timing
Sort[Sort/@r1]===Sort[Sort/@r2]===Sort[Sort/@r3]===Sort[Sort/@r4]
Out[10]=
{0.046 Second,Null}
Out[11]=
{0.641 Second,Null}
Out[12]=
{0.563 Second,Null}
Out[13]=
{0.234 Second,Null}
Out[14]=
True
Quite a bit quicker.
Carl Woll
Wolfram Research
(*dan lichtblau*)
aggregate[n_, pairs_] := Module[{hh, aggs, kk, ll,
mm, spairs = Sort[Map[Sort, pairs]], fm}, aggs = Map[hh, Range[n]];
Do[{kk, mm} = spairs[[j]];
ll = First[hh[kk]];
fm = First[hh[mm]];
If[fm === mm, hh[mm] = hh[ll], If[ll < fm, hh[mm] = hh[ll];
hh[First[hh[fm]]] = hh[ll], hh[
ll] = hh[mm]; ll = fm]];, {j, Length[spairs]}];
Last[Reap[Do[ll = hh[j]; Sow[j, ll], {j, n}]]]
]
(*carl woll*)
In[5]:=
agg[n_, pairs_] :=
Module[{sp, t, rowcounts, oldrowcounts, component, complete},
sp = SparseArray[Thread[pairs -> 1], {n, n}];
t = Sign[sp + SparseArray[{i_, i_} -> 1, {n, n}] + Transpose[sp]];
rowcounts = countrows[t];
Reap[
While[Total[rowcounts] > 0,
While[Max[rowcounts] > 15,
component = FixedPoint[
Sign[t.#1]&,
t[[Ordering[rowcounts, -1][[1]]]]
];
Sow[nonzeros[component]];
t = sparsediagonal[1 - component] . t;
rowcounts = countrows[t]
];
oldrowcounts = rowcounts;
t = Sign[t . t];
rowcounts = countrows[t];
complete = Sign[rowcounts] + Sign[oldrowcounts - rowcounts];
If[Total[complete] > 0,
tmp=(t.sparsediagonal[Range[n]])[[nonzeros[complete]]];
Sow /@ Union[List@@tmp /. SparseArray[_,_,_,{__, x_}]:>x];
t = sparsediagonal[1 - Sign[SparseArray[complete].t]] . t;
rowcounts = countrows[t];
]
]
][[2,1]]
]
countrows[s_] := s /. SparseArray[_, _, _, {_, {x_, _}, _}] :>
Rest[x] - Most[x]
sparsediagonal[v_] := SparseArray[Table[{i, i}, {i, Length[v]}] ->
Normal[v]]
nonzeros[a_] := SparseArray[a] /. SparseArray[_, _, _, x_] :>
Flatten[x[[2,2]]]
(*maxim*)
agg3[n_, Lpair_] := Module[{dfs, LLadj,
LvisitF, cc, cur, h, ans}, dfs[v_] := (LvisitF[[v]] = 1;
cc = {cc, v};
If[LvisitF[[#]] == 0, dfs[#]] & /@ LLadj[[v]];);
LLadj = Array[{} &, n];
(LLadj[[#]] = {LLadj[[#]], #2};
LLadj[[#2]] = {LLadj[[#2]], #}) & @@@ Lpair;
LLadj = Flatten /@ LLadj;
LvisitF = Array[0 &, n];
cur = 0;
ans = h[];
Block[{$RecursionLimit =
Infinity}, While[cur++ < n, If[LvisitF[[cur]] == 0, cc = {};
dfs[cur];
ans = h[ans, cc]]]];
List @@ Flatten /@ Flatten[ans, Infinity, h]]