从每个列表中最佳选择一个元素
|
我遇到了您可能喜欢Mathematica / StackOverflow的人们遇到的一个老问题，对于后代来说，在StackOverflow上看起来很有价值。
假设您有一个列表列表，并且想从每个列表中选择一个元素，然后将它们放在新列表中，以使与其下一个相邻元素相同的元素数量最大化。
换句话说，对于结果列表l，最小化Length @ Split [l]。
换句话说，我们希望列表中相同连续元素的中断最少。
例如：
pick[{ {1,2,3}, {2,3}, {1}, {1,3,4}, {4,1} }]
--> { 2, 2, 1, 1, 1 }
pick[x_] := argMax[-Length@Split[#]&, Tuples[x]]
没有找到相关结果
已邀请:
8 个回复
荆怖赡
f@{} := (Sow[m]; m = {i, 1}) f@x_ := m = {x, m[[2]] + 1} findruns[lst_] := Reap[m = {{}, 0}; f[m[[1]] ⋂ i] ~Do~ {i, lst}; Sow@m][[2, 1, 2 ;;]]给出游程长度编码的输出，包括并行答案。如果需要严格指定的输出，请使用：这是使用折页的一种变体。在某些设置的形状上速度更快，而在其他设置的形状上速度稍慢。f2[{}, m_, i_] := (Sow[m]; {i, 1}) f2[x_, m_, _] := {x, m[[2]] + 1} findruns2[lst_] := Reap[Sow@Fold[f2[#[[1]] ⋂ #2, ##] &, {{}, 0}, lst]][[2, 1, 2 ;;]]抹持奠糙驰
Table[RandomSample[Range[10], RandomInteger[{1, 7}]], {rl}]lst = Table[RandomSample[Range[ch], RandomInteger[{1, ch}]], {50}];鞘垒飘
LongestRuns[list_List] := Block[{gr, f = Intersection}, ReplaceRepeated[ list, {a___gr, Longest[e__List] /; f[e] =!= {}, b___} :> {a, gr[e], b}] /. gr[e__] :> ConstantArray[First[f[e]], Length[{e}]]]In[497]:= LongestRuns[{{1, 2, 3}, {2, 3}, {1}, {1, 3, 4}, {4, 1}}] Out[497]= {{2, 2}, {1, 1, 1}} In[498]:= LongestRuns[{{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 2, 8, 5, 9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8, 7}, {6, 9, 4, 5}}] Out[498]= {{3, 3, 3, 3}, {1}, {9, 9, 9}} In[499]:= pickPath[{{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 2, 8, 5, 9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8, 7}, {6, 9, 4, 5}}] Out[499]= {{10, 10, 10, 10}, {{1}, {9, 9, 9}}} In[500]:= LongestRuns[{{2, 8}, {4, 2}, {3}, {9, 4, 6, 8, 2}, {5}, {8, 10, 6, 2, 3}, {9, 4, 6, 3, 10, 1}, {9}}] Out[500]= {{2, 2}, {3}, {2}, {5}, {3, 3}, {9}} In[501]:= LongestRuns[{{4, 6, 18, 15}, {1, 20, 16, 7, 14, 2, 9}, {12, 3, 15}, {17, 6, 13, 10, 3, 19}, {1, 15, 2, 19}, {5, 17, 3, 6, 14}, {5, 17, 9}, {15, 9, 19, 13, 8, 20}, {18, 13, 5}, {11, 5, 1, 12, 2}, {10, 4, 7}, {1, 2, 14, 9, 12, 3}, {9, 5, 19, 8}, {14, 1, 3, 4, 9}, {11, 13, 5, 1}, {16, 3, 7, 12, 14, 9}, {7, 4, 17, 18, 6}, {17, 19, 9}, {7, 15, 3, 12}, {19, 12, 5, 14, 8}, {1, 10, 12, 8}, {18, 16, 14, 19}, {2, 7, 10}, {19, 2, 5, 3}, {16, 17, 3}, {16, 2, 6, 20, 1, 3}, {12, 18, 11, 19, 17}, {12, 16, 9, 20, 4}, {19, 20, 10, 12, 9, 11}, {10, 12, 6, 19, 17, 5}}] Out[501]= {{4}, {1}, {3, 3}, {1}, {5, 5}, {13, 13}, {1}, {4}, {9, 9, 9}, {1}, {7, 7}, {9}, {12, 12, 12}, {14}, {2, 2}, {3, 3}, {12, 12, 12, 12}}bfBestPick[e_List] := Block[{splits, gr, f = Intersection}, splits[{}] = {{}}; splits[list_List] := ReplaceList[ list, {a___gr, el__List /; f[el] =!= {}, b___} :> (Join[{a, gr[el]}, #] & /@ splits[{b}])]; Module[{sp = Cases[splits[ e] //. {seq__gr, re__List} :> (Join[{seq}, #] & /@ {re}), {__gr}, Infinity]}, sp[[First@Ordering[Length /@ sp, 1]]] /. gr[args__] :> ConstantArray[First[f[args]], Length[{args}]]]]test = {{4, 6, 18, 15}, {1, 20, 16, 7, 14, 2, 9}, {12, 3, 15}, {17, 6, 13, 10, 3, 19}, {1, 15, 2, 19}, {5, 17, 3, 6, 14}, {5, 17, 9}, {15, 9, 19, 13, 8, 20}, {18, 13, 5}, {11, 5, 1, 12, 2}, {10, 4, 7}, {1, 2, 14, 9, 12, 3}, {9, 5, 19, 8}, {14, 1, 3, 4, 9}, {11, 13, 5, 1}, {16, 3, 7, 12, 14, 9}, {7, 4, 17, 18, 6}, {17, 19, 9}, {7, 15, 3, 12}, {19, 12, 5, 14, 8}, {1, 10, 12, 8}, {18, 16, 14, 19}, {2, 7, 10}, {19, 2, 5, 3}, {16, 17, 3}, {16, 2, 6, 20, 1, 3}, {12, 18, 11, 19, 17}, {12, 16, 9, 20, 4}, {19, 20, 10, 12, 9, 11}, {10, 12, 6, 19, 17, 5}};In[637]:= Length[bfBestPick[test]] // Timing Out[637]= {58.407, 17} In[638]:= Length[LongestRuns[test]] // Timing Out[638]= {0., 17} In[639]:= Length[Cases[pickPath[test], {__Integer}, Infinity]] // Timing Out[639]= {0., 17}疮痪徘弦漏
list= {{4, 2, 7, 5, 1, 9, 10}, {10, 1, 8, 3, 2, 7}, {9, 2, 7, 3, 6, 4, 5}, {10, 3, 6, 4, 8, 7}, {7}, {3, 1, 8, 2, 4, 7, 10, 6}, {7, 6}, {10, 2, 8, 5, 6, 9, 7, 3}, {1, 4, 8}, {5, 6, 1}, {3, 2, 1}, {10,6, 4}, {10, 7, 3}, {10, 2, 4}, {1, 3, 5, 9, 7, 4, 2, 8}, {7, 1, 3}, {5, 7, 1, 10, 2, 3, 6, 8}, {10, 8, 3, 6, 9, 4, 5, 7}, {3, 10, 5}, {1}, {7, 9, 1, 6, 2, 4}, {9, 7, 6, 2}, {5, 6, 9, 7}, {1, 5}, {1,9, 7, 5, 4}, {5, 4, 9, 3, 1, 7, 6, 8}, {6}, {10}, {6}, {7, 9}}; runsByN = Transpose[Table[If[MemberQ[#, n], n, 0], {n, Max[list]}] & /@ list] Out = {{1, 1, 0, 0, 0, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, 0, 0,1, 1, 1, 0, 0, 0, 0}, {2, 2, 2, 0, 0, 2, 0, 2, 0, 0, 2, 0, 0, 2, 2,0, 2, 0, 0, 0, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0}, {0, 3, 3, 3, 0, 3, 0,3, 0, 0, 3, 0, 3, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0,0}, {4, 0, 4, 4, 0, 4, 0, 0, 4, 0, 0, 4, 0, 4, 4, 0, 0, 4, 0, 0, 4, 0, 0, 0, 4, 4, 0, 0, 0, 0}, {5, 0, 5, 0, 0, 0, 0, 5, 0, 5, 0, 0, 0, 0, 5, 0, 5, 5, 5, 0, 0, 0, 5, 5, 5, 5, 0, 0, 0, 0}, {0, 0, 6, 6, 0, 6, 6, 6, 0, 6, 0, 6, 0, 0, 0, 0, 6, 6, 0, 0, 6, 6, 6, 0, 0, 6, 6, 0,6, 0}, {7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0, 0, 7, 0, 7, 7, 7, 7, 0, 0, 7, 7, 7, 0, 7, 7, 0, 0, 0, 7}, {0, 8, 0, 8, 0, 8, 0, 8, 8, 0, 0, 0, 0, 0, 8, 0, 8, 8, 0, 0, 0, 0, 0, 0, 0, 8, 0, 0, 0, 0}, {9, 0, 9, 0, 0, 0, 0, 9, 0, 0, 0, 0, 0, 0, 9, 0, 0, 9, 0, 0, 9, 9, 9, 0, 9, 9, 0, 0, 0, 9}, {10, 10, 0, 10, 0, 10, 0, 10, 0, 0, 0, 10, 10, 10, 0, 0, 10, 10, 10, 0, 0, 0, 0, 0, 0, 0, 0, 10, 0, 0}};换为，并插入零以表示缺失的数字。它显示了其中出现1、2、3和4的子列表。 myPick：挑选构成最佳路径的数字递归建立最长运行时间的列表。它不会寻找所有最佳解决方案，而是寻找最小长度的第一个解决方案。myPick[{}, c_] := Flatten[c] myPick[l_, c_: {}] := Module[{r = Length /@ (l /. {x___, 0, ___} :> {x}), m}, m = Max[r]; myPick[Cases[(Drop[#, m]) & /@ l, Except[{}]], Append[c, Table[Position[r, m, 1, 1][[1, 1]], {m}]]]] choices = myPick[runsByN] (* Out= {7, 7, 7, 7, 7, 7, 7, 7, 1, 1, 1, 10, 10, 10, 3, 3, 3, 3, 3, 1, 1, 6, 6, 1, 1, 1, 6, 10, 6, 7} *)runsPlot[choices1_, runsN_] := Module[{runs = {First[#], Length[#]} & /@ Split[choices1], myArrow, m = Max[runsN]}, myArrow[runs1_] := Module[{data1 = Reverse@First[runs1], data2 = Reverse[runs1[[2]]], deltaX}, deltaX := data2[[1]] - 1; myA[{}, _, out_] := out; myA[inL_, deltaX_, outL_] := Module[{data3 = outL[[-1, 1, 2]]}, myA[Drop[inL, 1], inL[[1, 2]] - 1, Append[outL, Arrow[{{First[data3] + deltaX, data3[[2]]}, {First[data3] + deltaX + 1, inL[[1, 1]]}}]]]]; myA[Drop[runs1, 2], deltaX, {Thickness[.005], Arrow[{data1, {First[data1] + 1, data2[[2]]}}]}]]; ListPlot[runsN, Epilog -> myArrow[runs], PlotStyle -> PointSize[Large], Frame -> True, PlotRange -> {{1, Length[choices1]}, {1, m}}, FrameTicks -> {All, Range[m]}, PlotRangePadding -> .5, FrameLabel -> {\"Sublist\", \"Number\", \"Sublist\", \"Number\"}, GridLines :> {FoldList[Plus, 0, Length /@ Split[choices1]], None} ]]; runsPlot[choices, runsByN]的数据。 每个标绘点都对应一个数字及其所在的子列表。咳累录酬
pickPath[lst_List] := Module[{M = Fold[{#2, #} &, {{}}, Reverse@lst]}, Reap[While[M != {{}}, Do[Sow@#[[-2,1]], {Length@# - 1}] &@ NestWhileList[# ⋂ First[M = Last@M] &, M[[1]], # != {} &] ]][[2, 1]] ]M = Table[RandomSample[Range[1000], RandomInteger[{1, 200}]], {1000}];，详细说明列表中元素的存在：elements = Length@(Union @@ M); lists = Length@M; eList = Union @@ M; positions = Flatten@Table[{i, Sequence @@ First@Position[eList, M[[i,j]]} -> 1, {i, lists}, {j, Length@M[[i]]}]; K = Transpose@Normal@SparseArray@positions;R = {}; While[Length@K[[1]] > 0, len = LengthWhile[K[[row = Last@Ordering@K]], # == 1 &]; Do[AppendTo[R, eList[[row]]], {len}]; K = Drop[#, len] & /@ K; ]厘恼轨
pickPath[lst_] := Module[{lengthChoices, bestElement}, lengthChoices = LengthWhile[lst, Function[{lstMember}, MemberQ[lstMember, #]]] & /@First[lst]; bestElement = Ordering[lengthChoices][[-1]]; If[ Length[lst] == lengthChoices[[bestElement]], ConstantArray[lst[[1, bestElement]], lengthChoices[[bestElement]]], { ConstantArray[lst[[1, bestElement]], lengthChoices[[bestElement]]], pickPath[lst[[lengthChoices[[bestElement]] + 1 ;; -1]]] } ] ]In[12]:= lst = Table[RandomSample[Range[10], RandomInteger[{1, 7}]], {8}] Out[12]= {{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 2, 8, 5, 9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8, 7}, {6, 9, 4, 5}} In[13]:= pickPath[lst] // Flatten // AbsoluteTiming Out[13]= {0.0020001, {10, 10, 10, 10, 1, 9, 9, 9}}argMax[f_, dom_List] := Module[{g}, g[e___] := g[e] = f[e];(*memoize*) dom[[Ordering[g /@ dom, -1]]]] pick[x_] := argMax[-Length@Split[#] &, Tuples[x]] In[14]:= pick[lst] // AbsoluteTiming Out[14]= {0.7340420, {{10, 10, 10, 10, 1, 9, 9, 9}}}可扇胆
bestPick[lists_] := Module[ {picks, span, diffs, v, dv, vars, diffvars, fvars, c1, c2, c3, c4, constraints, obj, res}, span = Max[lists] - Min[lists]; vars = MapIndexed[v[Sequence @@ #2] &, lists, {2}]; picks = Total[vars*lists, {2}]; diffs = Differences[picks]; diffvars = Array[dv, Length[diffs]]; fvars = Flatten[{vars, diffvars}]; c1 = Map[Total[#] == 1 &, vars]; c2 = Map[0 <= # <= 1 &, fvars]; c3 = Thread[span*diffvars >= diffs]; c4 = Thread[span*diffvars >= -diffs]; constraints = Join[c1, c2, c3, c4]; obj = Total[diffvars]; res = Minimize[{obj, constraints}, fvars, Integers]; {res[[1]], Flatten[vars*lists /. res[[2]] /. 0 :> Sequence[]]} ]lists = {{1, 2, 3}, {2, 3}, {1}, {1, 3, 4}, {4, 1}} bestPick[lists]布埃郝卞簿
pick[data_] := Module[{common,tmp}, common = {}; tmp = Reverse[If[(common = Intersection[common,#])=={}, common = #, common]& /@ data]; common = .; Reverse[If[MemberQ[#, common], common, common = First[#]]& /@ tmp]]