Re: optimally picking one element from each list

*To*: mathgroup at smc.vnet.net*Subject*: [mg48362] Re: optimally picking one element from each list*From*: koopman at sfu.ca (Ray Koopman)*Date*: Tue, 25 May 2004 07:17:57 -0400 (EDT)*References*: <c8mugt$a3l$1@smc.vnet.net>*Sender*: owner-wri-mathgroup at wolfram.com

Daniel Reeves <dreeves at umich.edu> wrote in message news:<c8mugt$a3l$1 at smc.vnet.net>... > Suppose you have a list of lists and you want to pick one element from > each and put them in a new list so that the number of elements that are > identical to their next neighbor is maximized. > (in other words, for the resulting list l, minimize Length[Split[l]].) > (in yet other words, we want the list with the fewest interruptions of > identical contiguous elements.) > > EG, pick[{ {1,2,3}, {2,3}, {1}, {1,3,4}, {4,1} }] > --> { 2, 2, 1, 1, 1 } > [...] Here's a very simple brute-force function. In[1]:= picker[xlist_] := Fold[ If[Length[Split[#1]] <= Length[Split[#2]], #1, #2]&, First[#], Rest[#]]& [ Flatten[Outer[List, Delete[xlist,0]], Length[xlist]-1]] Try it on two different lists that others have used. (Times are for version 3 on a 33 MHz NeXT. YMMV) In[2]:= alist = {{1,3},{2,3},{1,3},{1,3,4},{4,1}}; In[3]:= picker[alist] // Timing Out[3]= {0.0781 Second,{3,3,1,1,1}} In[4]:= blist = {{6},{2},{2},{7,8},{3,4,1},{2,8,2},{5,2},{7}, {8,5,8},{2,1,7},{5},{5}}; In[5]:= picker[blist] // Timing Out[5]= {1.03073 Second,{6,2,2,7,3,2,2,7,8,2,5,5}} If elements are duplicated within a sublist then preprocessing the input list can save time (and give different answers, because ties can get broken differently). In[6]:= picker[Union /@ alist] // Timing Out[6]= {0.078146 Second,{3,3,1,1,1}} In[7]:= picker[Union /@ blist] // Timing Out[7]= {0.484291 Second,{6,2,2,7,1,2,2,7,5,1,5,5}} More time can be saved by a "divide-&-conquer" approach: don't apply picker to the whole list, but to super-sublists formed by grouping adjacent sublists that have common elements. In[8]:= splitter[xlist_] := Split[Union /@ xlist, (Length[Union[#1,#2]] < Length[#1]+Length[#2])&] In[9]:= Flatten@Map[If[Length[#] == 1, #[[1,1]], picker[#]]&, splitter[alist]] // Timing Out[9]= {0.093755 Second,{3,3,1,1,1}} In[10]:= Flatten@Map[If[Length[#] == 1, #[[1,1]], picker[#]]&, splitter[blist]] // Timing Out[10]= {0.046873 Second,{6,2,2,7,1,2,2,7,5,1,5,5}} Still more time can be saved by deleting elements that should never be picked. In[11]:= cutter[xlist_] := If[Length[xlist] == 2, {Select[xlist[[1]],MemberQ[xlist[[2]],#]&], Select[xlist[[2]],MemberQ[xlist[[1]],#]&]}, Join[ {Select[xlist[[1]],MemberQ[xlist[[2]],#]&]}, Table[Select[xlist[[i]], MemberQ[Union[xlist[[i-1]],xlist[[i+1]]],#]&], {i,2,Length[xlist]-1}], {Select[xlist[[-1]],MemberQ[xlist[[-2]],#]&]}]] In[12]:= Flatten@Map[If[Length[#] == 1, #[[1,1]], picker[cutter[#]]]&, splitter[alist]] // Timing Out[12]= {0.031256 Second,{3,3,1,1,1}} In[13]:= Flatten@Map[If[Length[#] == 1, #[[1,1]], picker[cutter[#]]]&, splitter[blist]] // Timing Out[13]= {0.031225 Second,{6,2,2,7,1,2,2,7,5,1,5,5}}

**Follow-Ups**:**Re: Re: optimally picking one element from each list***From:*DrBob <drbob@bigfoot.com>