Re: Re: Re: optimally picking one element from each list
- To: mathgroup at smc.vnet.net
- Subject: [mg48367] 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:18:15 -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> <opr8i15xqmiz9bcq@holycow.cox-internet.com> <1AE212A3-AE06-11D8-996B-000A95B4967A@mimuw.edu.pl>
- Sender: owner-wri-mathgroup at wolfram.com
My method can support a different cost function easily, but a different Split test affects the number of arcs (or tableau columns). Probably it could be done, but clearly, Backtrack is more amenable to it. The LP and shortest-path algorithms solve MANY problems, of course, and they're fast; the challenge is in recognizing and setting up individual applications.
As for Carl's method, it works, and it's fast, because there's not much "linkage" or dependency in the problem. Every time you incur a Split, the rest of the problem is completely independent of what came before. He takes intersections to find out when is the latest he can incur each split, and there's never any advantage in doing it sooner. Not many serious problems have so little linkage.
Here's a modification of Carl's algorithm that finds most (or all?) solutions. It doesn't actually list them, but you'll see what they are, pretty easily. pickForward and pickBackward each solve the problem, but in different directions. pickAll combines both solutions.
helper = If[(common = Intersection[common, #]) == {}, common = #, common] &;
onePass = (common = {}; Reverse[helper /@ #]) &;
cost = Length@Split@# &;
pickForward = onePass@onePass@# &;
pickBackward = Reverse@pickForward@Reverse@# &;
pickAll[data_] := {pickForward@data, pickBackward@data}
test=Array[Union@Array[Random[Integer,10]&,4]&,10]
pickAll@test
cost/@%
{{0,3,4,9},{0,4,8},{2,
9,10},{2,7,8},{1,3,5},{1,2,8,9},{0,2,4,5},{1,2,6,10},{0,4,9},{0,3,4}}
{{{0,4},{0,4},{2},{2},{1},{1},{2},{2},{0,4},{0,4}},{{0,4},{0,4},{2},{2},{1,
3,5},{2},{2},{2},{0,4},{0,4}}}
{5,5}
This is really fast. Here are ten thousand trials, solved both forward and backward, with a check to see if we get the same Split length both ways. The solutions are rarely the SAME in both directions, but COSTS are the same.
Timing[And@@Equal@@@Table[trial,{10000}]]
{6.265 Second,True}
Per solution, that's
6.265/20000
0.00031325
Bobby
On Tue, 25 May 2004 13:43:45 +0900, Andrzej Kozlowski <akoz at mimuw.edu.pl> wrote:
> Undobutedly Carl has once again showed the value of thinking before one
> starts programming: his algorithm is cleary the way to solve such
> problems.
> So I now find myself in a position a salesman stuck with an obsolete
> product and naturally I need a bit of skillful marketing. Well, the
> backtracking algorithm is vastly slower in this situation than Carl's
> approach, but maybe it has something to recommend it? I can think of
> two things. First of all, it is very easy, essentially without any loss
> of speed to adapt it to find all solutions rather than just one, for
> after all it has to do that anyway. Of course Carl's method can also be
> so adapted, but that will make it already somewhat slower. Secondly,
> the approach is very flexible, one can for example replace Split by
> Split[#,test] where test is any test. I am not sure if it is possible
> to do that using Intersection[,SameTest ->test] and Carl's method; I
> tried it briefly but could not make it work. Anyway, here is the more
> general code:
>
>
> << DiscreteMath`Combinatorica`
>
> BacktrackPick[sp_, tst_:SameQ] := Block[{n = Length[sp], c = Length[
> sp], w, partialQ, solutionQ, sols},
> partialQ[l_List] := Which[Length[l] == n && (w = Length[Split[l,
> tst]]) <= c, c = w; True, Length[l] < n &&
> Length[Split[l, tst]] <= c, True, True, False];
> solutionQ[l_List] := If[Length[l] ==
> n && (w = Length[Split[l, tst]]) <= c, c = w; True, False];
> sols =
> Backtrack[sp, partialQ,
> solutionQ, All]; Select[sols,
> Length[Split[#, tst]] == Length[Split[Last[sols], tst]] &]]
>
>
> Suppose we take the list
>
> sp = {{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}};
>
> and suppose we want to solve Daniel's problems but we consider
> sequences which jump by less than 1 (up or down). In other words, we
> minimise Split[ ,Abs[#1-#2]<=1&].
>
> Here is the complete solution:
>
> In[50]:=
> Timing[BacktrackPick[sp, Abs[#1 - #2] <= 1 & ]]
>
> Out[50]=
> {0.20000000000000284*Second,
> {{5, 4, 3, 4, 4, 4, 4, 3, 2, 1}, {5, 4, 3, 4, 4, 4, 4,
> 3, 2, 3}, {5, 4, 5, 4, 4, 4, 4, 3, 2, 1},
> {5, 4, 5, 4, 4, 4, 4, 3, 2, 3}, {5, 5, 5, 4, 4, 4, 4,
> 3, 2, 1}, {5, 5, 5, 4, 4, 4, 4, 3, 2, 3}}}
>
> Andrzej Kozlowski
>
>
>
> On 25 May 2004, at 08:28, DrBob wrote:
>
>> 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/
>>
>>
>
>
--
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