MathGroup Archive 2005

[Date Index] [Thread Index] [Author Index]

Search the Archive

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


  • Prev by Date: Re: 2.9.2 How Input and Output Work
  • Next by Date: Re: Re: aggregation of related elements in a list
  • Previous by thread: Re: Re: Re: Re: aggregation of related elements in a list
  • Next by thread: Re: Re: aggregation of related elements in a list