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: aggregation of related elements in a list