Re: Re: aggregation of related elements in a list

*To*: mathgroup at smc.vnet.net*Subject*: [mg61629] Re: [mg61611] Re: aggregation of related elements in a list*From*: Chris Chiasson <chris.chiasson at gmail.com>*Date*: Mon, 24 Oct 2005 01:44:20 -0400 (EDT)*References*: <djcgcs$6du$1@smc.vnet.net> <200510230946.FAA10826@smc.vnet.net>*Sender*: owner-wri-mathgroup at wolfram.com

You could run UnsortedUnion first... didn't David Park say you wrote that function? On 10/23/05, Carl K. Woll <carlw at u.washington.edu> wrote: > 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 > > > > {{x1},{x2,x5,x7),.......} > > > > To take a specific example, assume we have the list > > > > list={1,2,6,7,8,9,11,16} > > > > and that application of the relatedQ, test to all possible pairs yields > > the list of related pairs > > > > prlist={{1,2},{1,6},{2,6},{2,7},{6,7},{6,11},{7,8},{7,11},{11,16}} > > > > Using the list and the list of related pairs we can deduce the desired > > list of lists as > > > > {{1,2,6,7,8,11,16},{9}} > > > > Here's one suboptimal method. I give steps tailored for your example. It > shouldn't be too difficult encapsulate these steps into a nice function. > Here are the steps. Construct a transition matrix: > > sp1 = SparseArray[Thread[prlist -> 1], {16, 16}]; > sp2 = SparseArray[{#, #} -> 1 & /@ list, {16, 16}]; > > In[13]:= > t = sp1 + sp2 + Transpose[sp1] > Out[13]= > SparseArray[<24>, {16, 16}] > > Multiply t by itself (and take it's sign) until the result doesn't change: > > In[14]:= > FixedPoint[Sign[#.#]&,t] > Out[14]= > SparseArray[<50>, {16, 16}] > > The different rows of the fixed point are the different sets you are > interested in: > > In[15]:= > Union[Normal[%14]] > Out[15]= > {{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, > > {0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0}, > > {1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 0, 1}} > > If you prefer a list of integer sets: > > In[16]:= > Flatten[Position[#,1]]&/@%15 > Out[16]= > {{}, {9}, {1, 2, 6, 7, 8, 11, 16}} > > > If 6 were not in the original list we would get instead > > > > {{1,2},{7,8,11,16},{9}} > > > > Since your original pair list had the pair {2,7}, I think the result should > still be {{1,2,7,8,11,16},{9}}. At any rate, to use the transition matrix > approach, you would need to delete all pairs that had elements not in your > list, and then look for the fixed point. In your example with 6 deleted from > list, you would also need to delete all 6s from prlist: > > newprlist = DeleteCases[prlist,{6,_}|{_,6}] > > and then proceed as before using newprlist instead of prlist. This method > does extra work based on how large your final integer sets are. However, > matrix multiplication of sparse matrices is extremely quick, so I think it > ought to be at least competitive with other approaches. > > Carl Woll > Wolfram Research > > > I have tried to develop a Mathematica function or procedure to produce > > this list, but am having trouble achieving it. Can anyone help? > > > > The algorithm I have been trying to implement is: > > - form a list of all related pairs and singletons in the original list > > by comparing all pairs to prlist > > - then compare the first element in the resulting list with each of the > > others in that list and form the Union of all those where (Intersection > > !={}) > > - delete all pairs retained for the Union. > > - repeat the process for the next element in the list and so on. > > > > The following ugly code seems to work on some lists, but with others > > gives me an error message, presumably an objection to a dynamic > > redefinition of the list inside a Do statement. > > > > In[87]:= > > chains[n_]:=Block[{lst,tmp,tmp2,lst2}, > > lst={1,2,6,7,8,9,11,16}; > > tmp=Flatten[ > > Part[Reap[ > > Do[{If[Intersection[{{Part[lst,i],Part[lst,j]}}, > > Edges[gr1[n]]]\[NotEqual]{}, > > > > Sow[{Part[lst,i],Part[lst,j]}]],Sow},{i,1,Length[lst]-1},{j, > > i+1,Length[lst]}]],2],1]; > > tmp2=Part[ > > Reap[Do[If[Intersection[{lst[[i]]},Flatten[tmp]]\[Equal]{}, > > Sow[lst[[i]]]],{i,1,Length[lst]}]],2]; > > lst2=Union[tmp,tmp2]; > > Do > > [ > > { > > If > > [ > > Intersection[lst2[[i]],lst2[[j]]]\[NotEqual]{}, > > {lst2[[i]]=Union[lst2[[i]],lst2[[j]]],lst2=Delete[lst2,j]} > > ] > > }, > > {i,1,Length[lst2]-1}, > > {j,i+1,Length[lst2]} > > ]; > > lst2 > > ] > > chains[4] > > I have been doing much Intersecting, Unions, Deletions, nested loops and > > Sowing, but have so far been unable to Reap the result that I want! > > There should be a simple recursive function that will do what I want, > > but I can't find it. > > > > Thanks for any help > > > > LP > > > > > -- http://chrischiasson.com/contact/chris_chiasson

**References**:**Re: aggregation of related elements in a list***From:*"Carl K. Woll" <carlw@u.washington.edu>

**Re: Re: significance arithmetic and numeric equation solving**

**Re: Re: significance arithmetic and numeric equation solving**

**Re: aggregation of related elements in a list**

**Re: Re: aggregation of related elements in a list**