Re: Re: optimally picking one element from each list
- To: mathgroup at smc.vnet.net
- Subject: [mg48405] Re: [mg48362] Re: optimally picking one element from each list
- From: DrBob <drbob at bigfoot.com>
- Date: Fri, 28 May 2004 00:50:34 -0400 (EDT)
- References: <c8mugt$a3l$1@smc.vnet.net> <200405251117.HAA03713@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
Fascinating! I really like the way you laid this out, and showed incremental improvements.
The divide-and-conquer approach is usually twice as fast as my solver, but sometimes a hundred times slower, and I ran into an example with 15 sets:
{{4, 6, 8}, {2, 5, 7}, {0, 2, 4, 8}, {4, 8, 10}, {1, 2, 4, 5}, {0, 1, 5,
10}, {0, 1, 7, 8}, {0, 6, 7, 9}, {3, 4, 9, 10}, {1,
2, 9, 10}, {0, 1, 6}, {1, 2, 7, 10}, {0, 1, 4}, {0, 6, 7}, {1, 4, 6, 10}}
that made my machine run out of memory. Perhaps it was already getting low, though.
Your final approach, combining divide-and-conquer with removing elements, is better behaved, but still not as consistently fast as Carl K. Woll's solver. For some large problems, my solver will beat it (depending on how much dividing and conquering occurs). If all the adjacent sets intersect, and there are many of them, you won't do very well at all.
I thought Distribute would be better than Outer (since Flatten isn't needed afterward, for one thing), but I found that your construction is a third faster, or thereabouts.
I would suggest you use Sequence@@xlist rather than Delete[xlist,0]. The latter obscures (in my opinion) what you're trying to do.
Bobby
On Tue, 25 May 2004 07:17:57 -0400 (EDT), Ray Koopman <koopman at sfu.ca> wrote:
> 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}}
>
>
--
Using M2, Opera's revolutionary e-mail client: http://www.opera.com/m2/
- References:
- Re: optimally picking one element from each list
- From: koopman@sfu.ca (Ray Koopman)
- Re: optimally picking one element from each list