Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2005
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

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: [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
> 



  • Prev by Date: Re: Re: regress versus fit - force throughzero/forceconstant term to zero
  • Next by Date: Re: Re: Warning from Piecewise
  • Previous by thread: Re: aggregation of related elements in a list
  • Next by thread: Re: Re: aggregation of related elements in a list