Re: Re: Re: optimally picking one element from each list
- To: mathgroup at smc.vnet.net
- Subject: [mg48333] 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:16:48 -0400 (EDT)
- References: <200405220704.DAA08848@smc.vnet.net> <200405231015.GAA21155@smc.vnet.net> <200405240445.AAA08868@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
Oops, more testing shows that's not quite right! I'm working on a solution, using LinearProgramming.
Bobby
On Mon, 24 May 2004 00:45:20 -0400 (EDT), DrBob <drbob at bigfoot.com> 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/
- 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