Re: aggregation of related elements in a list
- To: mathgroup at smc.vnet.net
- Subject: [mg61611] Re: aggregation of related elements in a list
- From: "Carl K. Woll" <carlw at u.washington.edu>
- Date: Sun, 23 Oct 2005 05:46:36 -0400 (EDT)
- Organization: University of Washington
- References: <djcgcs$6du$1@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
>
> {{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
>
- Follow-Ups:
- Re: Re: aggregation of related elements in a list
- From: Chris Chiasson <chris.chiasson@gmail.com>
- Re: Re: aggregation of related elements in a list