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