Re: Re: Re: optimally picking one element from each list
- To: mathgroup at smc.vnet.net
- Subject: [mg48360] Re: [mg48324] Re: [mg48308] Re: [mg48297] optimally picking one element from each list
- From: DrBob <drbob at bigfoot.com>
- Date: Tue, 25 May 2004 07:17:45 -0400 (EDT)
- References: <200405220704.DAA08848@smc.vnet.net> <200405231015.GAA21155@smc.vnet.net> <200405240445.AAA08868@smc.vnet.net> <E2802AB0-AD75-11D8-9FDB-000A95B4967A@mimuw.edu.pl> <opr8itwntoiz9bcq@holycow.cox-internet.com> <65B6A480-ADCA-11D8-996B-000A95B4967A@mimuw.edu.pl>
- Sender: owner-wri-mathgroup at wolfram.com
Here are a couple of timings for the three methods (Carl Woll's, mine, and Andrzej Kozlowski's). My method probably uses too much memory for large problems, and Andrzej's uses too much time. Both could be optimized, but Carl's method would still beat them.
test=Array[Union@Array[Random[Integer,10]&,4]&,10]
Timing[pick@test]
Timing[optimalSplit@test]
Timing[BacktrackPick@test]
{{1,5,7},{4,5,8,9},{3,5,6,8},{4,7,9,10},{4,7,9,10},{0,4,10},{2,4,8,10},{
3,5,8},{2,5,7,8},{1,3,7,10}}
{0. Second,{4,{5,5,5,4,4,4,4,5,5,1}}}
{0.063 Second,{4,{5,5,5,4,4,4,4,5,5,1}}}
{1.531 Second,{4,{5,5,5,10,10,10,10,8,8,10}}}
test=Array[Union@Array[Random[Integer,10]&,4]&,10]
Timing[pick@test]
Timing[optimalSplit@test]
Timing[BacktrackPick@test]
{{1,3,6,7},{2,6,10},{1,2,3},{1,6,10},{5,
9,10},{1,2,6},{6,8},{4,6,8},{2,3,5,8},{1,3,4,8}}
{0. Second,{5,{6,6,1,1,5,6,6,6,3,3}}}
{0.047 Second,{5,{6,6,1,1,5,6,6,6,3,3}}}
{0.468 Second,{5,{7,2,2,10,10,6,8,8,8,8}}}
Bobby
On Tue, 25 May 2004 06:36:20 +0900, Andrzej Kozlowski <akoz at mimuw.edu.pl> wrote:
> It seems that I somehow sent a "pre-release" version of my code instead
> fo the finished one. It should have been:
>
>
> << "DiscreteMath`Combinatorica`"
>
>
> BacktrackPick[sp_] := Block[{n = Length[sp], c = Length[sp], w,
> partialQ, solutionQ},
> partialQ[l_List] := Which[Length[l] == n && (w = Length[Split[l]])
> <= c, c = w; True,
> Length[l] < n && Length[Split[l]] <= c, True, True, False];
> solutionQ[l_List] := If[Length[l] == n && (w = Length[Split[l]]) <=
> c, c = w; True, False];
> Last[Backtrack[sp, partialQ, solutionQ, All]]]
>
>
> Andrzej
>
>
>
>
>
>
> On 25 May 2004, at 05:30, DrBob wrote:
>
>> I got errors (see attached) before getting to any tests.
>>
>> Bobby
>>
>> On Mon, 24 May 2004 20:31:23 +0900, Andrzej Kozlowski
>> <akoz at mimuw.edu.pl> wrote:
>>
>>> What errors do you get and on what examples? At least on the ones you
>>> gave below my function works fine. I have not yet found one where it
>>> fails.
>>>
>>> As I wrote in the original posting, I am sure it can be made faster if
>>> someone wrote an optimised backtracking code rather than rely on the
>>> Backtrack function form the Combinatorica package. But I do not wish
>>> to
>>> spend time on this.
>>>
>>> Using compiled optimizers ought to be faster, maybe much faster on the
>>> whole, though perhaps not in all cases. Performance in this sort of
>>> problem seems to depend very much on the starting configuration. For
>>> example, if if the backtracking algorithm happens to find a "best"
>>> solution early on it will finish much earlier than when it finds it
>>> only near the end of the search.
>>>
>>>
>>> Andrzej
>>>
>>> On 24 May 2004, at 13:45, DrBob wrote:
>>>
>>>> I get errors when I try Andrzej's function; maybe others had more
>>>> luck?
>>>>
>>>> Here's a solution using Minimize. It may be wasteful in the setup,
>>>> but
>>>> solution will be very fast. I'm not certain a Sort isn't needed
>>>> somewhere in the last statement, but this seems OK.
>>>>
>>>> An even faster method would solve a corresponding shortest path
>>>> problem, if we have a solver available. I don't have to require or
>>>> check for integer solutions below, because of that correspondence;
>>>> basic optimal solutions will be integer automatically.
>>>>
>>>> Clear[choice, optimize]
>>>> optimize[raw:{__List}] :=
>>>> Module[{sets = Union /@ raw, choice, costBounds,
>>>> choiceConstraints, pVar, costConstraints,
>>>> objective, p, cVar, vars, bounds, solution},
>>>> choice[set_, {index_}] :=
>>>> Plus @@ (p[index, #1] & ) /@ set == 1;
>>>> costBounds[{set1_, set2_}, {index_}] :=
>>>> Module[{switches},
>>>> switches = Plus @@ (p[index, #1] & ) /@
>>>> Complement[set1, set2];
>>>> {(cost[index] >= switches + (p[index, #1] -
>>>> p[index + 1, #1]) & ) /@ Intersection[
>>>> set1, set2], cost[index] >= switches}];
>>>> choiceConstraints = Flatten[MapIndexed[choice,
>>>> sets]]; pVar = Union[Cases[choiceConstraints,
>>>> _p, Infinity]]; costConstraints =
>>>> Flatten[MapIndexed[costBounds, Partition[sets, 2,
>>>> 1]]]; cVar = Union[Cases[costConstraints,
>>>> _cost, {2}]]; objective = Plus @@ cVar;
>>>> vars = Flatten[{pVar, cVar}];
>>>> bounds = Thread[0 <= vars <= 1];
>>>> solution = Minimize[Flatten[{objective,
>>>> choiceConstraints, costConstraints, bounds}],
>>>> vars]; Cases[Last[solution] /. Rule -> rule,
>>>> rule[p[_, a_], 1] :> a]]
>>>>
>>>> Timing@optimize@{{1,3},{2,3},{1,3},{1,3,4},{4,1}}
>>>> Timing@optimize@{{6},{2},{2},{7,8},{3,4,1},{2,8,2},{5,2},{7},{8,5,8},
>>>> {2
>>>> ,1,
>>>> 7},{5},{5}}
>>>>
>>>> {0.06299999999999999*Second, {3, 3, 3, 3, 1}}
>>>> {0.015000000000000013*Second, {6, 2, 2, 7, 1, 2, 2, 7, 5, 1, 5, 5}}
>>>>
>>>> Bobby
>>>>
>>>> On Sun, 23 May 2004 06:15:35 -0400 (EDT), Andrzej Kozlowski
>>>> <akoz at mimuw.edu.pl> wrote:
>>>>
>>>>>
>>>>> On 22 May 2004, at 16:04, Daniel Reeves wrote:
>>>>>
>>>>>> 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 preposterously brute force solution:
>>>>>>
>>>>>> pick[x_] := argMax[-Length[Split[#]]&, Distribute[x, List]]
>>>>>>
>>>>>> where argMax can be defined like so:
>>>>>>
>>>>>> (* argMax[f,domain] returns the element of domain for which f of
>>>>>> that element is maximal -- breaks ties in favor of first
>>>>>> occurrence.
>>>>>> *)
>>>>>> SetAttributes[argMax, HoldFirst];
>>>>>> argMax[f_, dom_List] := Fold[If[f[#1] >= f[#2], #1, #2] &,
>>>>>> First[dom], Rest[dom]]
>>>>>>
>>>>>> Below is an attempt at a search-based approach, which is also way
>>>>>> too
>>>>>> slow. So the gauntlet has been thrown down. Anyone want to give
>>>>>> it
>>>>>> a
>>>>>> shot?
>>>>>>
>>>>>>
>>>>>> (* Used by bestFirstSearch. *)
>>>>>> treeSearch[states_List, goal_, successors_, combiner_] :=
>>>>>> Which[states=={}, $Failed,
>>>>>> goal[First[states]], First[states],
>>>>>> True, treeSearch[
>>>>>> combiner[successors[First[states]],
>>>>>> Rest[states]],
>>>>>> goal, successors, combiner]]
>>>>>>
>>>>>> (* Takes a start state, a function that tests whether a state is a
>>>>>> goal
>>>>>> state, a function that generates a list of successors for a
>>>>>> state,
>>>>>> and
>>>>>> a function that gives the cost of a state. Finds a goal state
>>>>>> that
>>>>>> minimizes cost.
>>>>>> *)
>>>>>> bestFirstSearch[start_, goal_, successors_, costFn_] :=
>>>>>> treeSearch[{start}, goal, successors,
>>>>>> Sort[Join[#1,#2], costFn[#1] < costFn[#2] &]&]
>>>>>>
>>>>>> (* A goal state is one for which we've picked one element of every
>>>>>> list
>>>>>> in l.
>>>>>> *)
>>>>>> goal[l_][state_] := Length[state]==Length[l]
>>>>>>
>>>>>> (* If in state s we've picked one element from each list in l up to
>>>>>> list
>>>>>> i, then the successors are all the possible ways to extend s to
>>>>>> pick
>>>>>> elements thru list i+1.
>>>>>> *)
>>>>>> successors[l_][state_] := Append[state,#]& /@ l[[Length[state]+1]]
>>>>>>
>>>>>> (* Cost function g: higher cost for more neighbors different
>>>>>> (Length[Split[state]]) and then breaks ties in favor of longer
>>>>>> states to keep from unnecessarily expanding the search tree.
>>>>>> *)
>>>>>> g[l_][state_] :=
>>>>>> Length[Split[state]]*(Length[l]+1)+Length[l]-Length[state]
>>>>>>
>>>>>> (* Pick one element from each of the lists in l so as to minimize
>>>>>> the
>>>>>> cardinality of Split, ie, maximize the number of elements that
>>>>>> are
>>>>>> the same as their neighbor.
>>>>>> *)
>>>>>> pick[l_] := bestFirstSearch[{}, goal[l], successors[l], g[l]]
>>>>>>
>>>>>>
>>>>>> --
>>>>>> http://ai.eecs.umich.edu/people/dreeves - - google://"Daniel
>>>>>> Reeves"
>>>>>>
>>>>>> If you must choose between two evils,
>>>>>> pick the one you've never tried before.
>>>>>>
>>>>>>
>>>>>>
>>>>>
>>>>> Here is an approach which, while not really fast, at least is much
>>>>> faster than yours. It will correctly minimize Length[Split[l]], but
>>>>> will not necessarily give the same answer as your approach because I
>>>>> have not bothered to make sure that ties are settled in the way you
>>>>> indicated. It should not be hard to modify it to do so but I did not
>>>>> really wish to spend time on this matter.
>>>>>
>>>>> The idea is to use the Backtrack function from
>>>>> DiscreteMath`Combinatorica`.
>>>>>
>>>>> Here is the program:
>>>>>
>>>>> <<DiscreteMath`Combinatorica`
>>>>>
>>>>> BacktrackPick[l_]:= Block[{n = Length[sp], c = Length[sp], w},
>>>>> partialQ[l_List] := Which[Length[l] == n && (w = Length[Split[
>>>>> l]]) <= c, c = w; True, Length[l] < n &&
>>>>> Length[Split[l]] <= c, True, True, False];
>>>>> solutionQ[l_List] := If[Length[l] == n && (w =
>>>>> Length[Split[l]])
>>>>> <=
>>>>> c,
>>>>> c = w; True, False]; Last[Backtrack[sp, partialQ,
>>>>> solutionQ,
>>>>> All]]]
>>>>>
>>>>>
>>>>> To see how this compares with yours let's create a random test case:
>>>>>
>>>>>
>>>>>
>>>>> sp=Table[Table[Random[Integer,{1,9}],{Random[Integer,{1,3}]}],{12}]
>>>>>
>>>>>
>>>>> {{6},{2},{2},{7,8},{3,4,1},{2,8,2},{5,2},{7},{8,5,8},{2,1,7},{5},{5}
>>>>> }
>>>>>
>>>>> Let's try your pick function:
>>>>>
>>>>>
>>>>> Length[Split[sol1=pick[sp]]]//Timing
>>>>>
>>>>>
>>>>> {15.33 Second,9}
>>>>>
>>>>> Now BacktrackPick:
>>>>>
>>>>>
>>>>> Length[Split[sol2=BacktrackPick[sp]]]//Timing
>>>>>
>>>>>
>>>>> {0.34 Second,9}
>>>>>
>>>>> Quite a difference. This time the answers happened to be the same:
>>>>>
>>>>>
>>>>> sol1
>>>>>
>>>>> {6,2,2,8,1,2,2,7,8,7,5,5}
>>>>>
>>>>> sol2
>>>>>
>>>>> {6,2,2,8,1,2,2,7,8,7,5,5}
>>>>>
>>>>> But this will not be the case in general.
>>>>>
>>>>> I am sure that one can write a customised backtracking solution that
>>>>> will be much faster than mine. However, writing customised (that is
>>>>> without using Backtrack) backtracking programs is a bit of an art
>>>>> that
>>>>> requires patience and care and I have a short supply of both of
>>>>> these.
>>>>> So I am cc-ing this message to a well known member of this list who
>>>>> is
>>>>> a real master in this sort of thing ;-) so he might be interested in
>>>>> taking up the challenge.
>>>>>
>>>>> Andrzej Kozlowski
>>>>>
>>>>>
>>>>
>>>>
>>>>
>>>> --
>>>> Using M2, Opera's revolutionary e-mail client:
>>>> http://www.opera.com/m2/
>>>>
>>>>
>>>
>>>
>>
>>
>>
>> --
>> Using M2, Opera's revolutionary e-mail client:
>> http://www.opera.com/m2/<Andrzej.nb>
>
>
--
Using M2, Opera's revolutionary e-mail client: http://www.opera.com/m2/
- References:
- optimally picking one element from each list
- From: Daniel Reeves <dreeves@umich.edu>
- Re: optimally picking one element from each list
- From: Andrzej Kozlowski <akoz@mimuw.edu.pl>
- Re: Re: optimally picking one element from each list
- From: DrBob <drbob@bigfoot.com>
- optimally picking one element from each list