Re: Re: Re: optimally picking one element from each list

*To*: mathgroup at smc.vnet.net*Subject*: [mg48340] Re: [mg48324] Re: [mg48308] Re: [mg48297] optimally picking one element from each list*From*: Andrzej Kozlowski <akoz at mimuw.edu.pl>*Date*: Tue, 25 May 2004 07:17:02 -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

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/ > >

**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>

**Re: Re: Re: optimally picking one element from each list**

**Re: Re: Re: optimally picking one element from each list**

**Re: Re: Re: Re: optimally picking one element from each list**

**Re: Re: Re: optimally picking one element from each list**