从每个列表中最佳选择一个元素

问题描述

| 我遇到了您可能喜欢Mathematica / StackOverflow的人们遇到的一个老问题，对于后代来说，在StackOverflow上看起来很有价值。 假设您有一个列表列表，并且想从每个列表中选择一个元素，然后将它们放在新列表中，以使与其下一个相邻元素相同的元素数量最大化。 换句话说，对于结果列表l，最小化Length @ Split [l]。 换句话说，我们希望列表中相同连续元素的中断最少。 例如：

pick[{ {1,2,3},{2,{1},{1,3,4},{4,1} }]
 --> {    2,1,1   }

（或者{3,1}同样好。） 这是一个荒谬的蛮力解决方案：

pick[x_] := argMax[-Length@Split[#]&,Tuples[x]]

其中argMax如下所述： posmax：类似于argmax，但给出f [x]最大的元素x的位置 你能想出更好的东西吗？ 传奇人物卡尔·沃尔（Carl Woll）为我做到了这一点，我将在一周内揭示他的解决方案。     

解决方法

我将它扔进去。我不确定它总是能提供最佳解决方案，但它似乎可以与其他给出的答案在相同的逻辑上工作，而且速度很快。

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 ;;]]

findruns

给出游程长度编码的输出，包括并行答案。如果需要严格指定的输出，请使用：

Flatten[First[#]~ConstantArray~#2 & @@@ #] &

这是使用折页的一种变体。在某些设置的形状上速度更快，而在其他设置的形状上速度稍慢。

f2[{},m_,i_] := (Sow[m]; {i,1})
f2[x_,_] := {x,m[[2]] + 1}

findruns2[lst_] :=
  Reap[Sow@Fold[f2[#[[1]] ⋂ #2,##] &,{{},0},lst]][[2,2 ;;]]

    ,不是答案，而是这里提出的方法的比较。我生成了具有可变数量子集的测试集，该子集的数量从5到100不等。每个测试集都是使用此代码生成的

Table[RandomSample[Range[10],RandomInteger[{1,7}]],{rl}]

其中rl涉及的子集数量。 对于以这种方式生成的每个测试集，我都有所有算法来做。我用随机顺序运行的算法做了10次（使用相同的测试集），以使顺序效果和笔记本电脑上的随机后台进程的效果趋于平稳。这将导致给定数据集的平均计时。对于每个rl长度，将上述行使用20次，从中计算出平均值（均值）和标准差。 结果如下（水平子集数量，垂直绝对平均值）： 向导先生似乎是（不清楚）赢家。恭喜！ 更新资料 根据Timo的要求，时序取决于可从中选择的不同子集元素的数量以及每个子集中元素的最大数量。根据以下代码行为固定数量的子集（50）生成数据集：

lst = Table[RandomSample[Range[ch],ch}]],{50}];

我还将为每个值尝试的数据集数量从20增加到40。 这里有5个子集：     ,这是我的观点，它与Sjoerd几乎一样，只是用更少的代码。

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,{1},{1,3,4},{4,1}}]

Out[497]= {{2,2},1}}

In[498]:= LongestRuns[{{3,10,6},{8,5,9,{3,7,8,9},{6,10},{9,6,7},4,5}}]

Out[498]= {{3,9}}

In[499]:= pickPath[{{3,5}}]

Out[499]= {{10,{{1},9}}}

In[500]:= LongestRuns[{{2,8},{3},{5},1},{9}}]

Out[500]= {{2,{2},{9}}

In[501]:= LongestRuns[{{4,18,15},20,16,14,{12,{17,13,19},15,{5,17,14},{15,19,20},{18,5},{11,12,{10,{14,{16,{7,12},{19,11,17},11},5}}]

Out[501]= {{4},{13,13},{4},{9},{14},12}}

鉴于Sjoerd's Dreeves的蛮力方法由于无法一次生成所有元组而无法在大样本上使用，因此进行编辑，这是另一种蛮力方法：

bfBestPick[e_List] := Block[{splits,gr,splits[{}] = {{}};
  splits[list_List] := 
   ReplaceList[
    list,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,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}

我发布此消息是为了防止有人想搜索诸如pickPath或LongestRuns之类的代码确实生成中断次数最少的序列的反例。     ,这是一个尝试... runByN：对于每个数字，请显示其是否出现在每个子列表中

list= {{4,{7},{6},{10},9}};
runsByN = Transpose[Table[If[MemberQ[#,n],n,0],{n,Max[list]}] & /@ list]
Out = {{1,{0,0}};

runsByN

换为

list

，并插入零以表示缺失的数字。它显示了其中出现1、2、3和4的子列表。 myPick：挑选构成最佳路径的数字

myPick

递归建立最长运行时间的列表。它不会寻找所有最佳解决方案，而是寻找最小长度的第一个解决方案。

myPick[{},c_] := Flatten[c]
myPick[l_,c_: {}] := 
   Module[{r = Length /@ (l /. {x___,___} :> {x}),m},m = Max[r];
   myPick[Cases[(Drop[#,m]) & /@ l,Except[{}]],Append[c,Table[Position[r,m,1][[1,1]],{m}]]]]
choices = myPick[runsByN]
(* Out= {7,7} *)

感谢Wizard先生建议使用替代规则作为ѭ18的有效替代方法。 Epilog：可视化解决方案路径

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,2]]},myA[Drop[inL,1],inL[[1,2]] - 1,Append[outL,Arrow[{{First[data3] + deltaX,data3[[2]]},{First[data3] + deltaX + 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]},m}},FrameTicks -> {All,Range[m]},PlotRangePadding -> .5,FrameLabel -> {\"Sublist\",\"Number\",\"Sublist\",\"Number\"},GridLines :>    {FoldList[Plus,Length /@ Split[choices1]],None}
   ]];

runsPlot[choices,runsByN]

下图表示来自

list

的数据。 每个标绘点都对应一个数字及其所在的子列表。     ,因此，这是我的“一个班轮”，经过Wizard先生的改进：

 pickPath[lst_List] :=
 Module[{M = Fold[{#2,#} &,{{}},Reverse@lst]},Reap[While[M != {{}},Do[Sow@#[[-2,{Length@# - 1}] &@
       NestWhileList[# ⋂ First[M = Last@M] &,M[[1]],# != {} &]
   ]][[2,1]]
 ]

它基本上在连续的列表上重复使用交集，直到它变空为止，然后一次又一次地使用它。在一个巨大的酷刑测试案例中

M = Table[RandomSample[Range[1000],200}]],{1000}];

我在2GHz Core 2 Duo上始终获得0.023英镑的23英镑。 这是我的第一次尝试，将留给您仔细阅读。 对于元素of24ѭ的给定列表，我们计算不同的元素和列表的数量，以规范的顺序列出不同的元素，并构造矩阵

K[i,j]

，详细说明列表

j

中元素

i

的存在：

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;

现在的问题等效于仅踩1并尽可能少地更改行，从而从左到右遍历此矩阵。 要实现此目的，我要对行进行“ѭ29”操作，以开始时最连续的1 \开头，跟踪我选择的元素，从“ѭ31”中选择那么多的行“ѭ30”，然后重复：

R = {};
While[Length@K[[1]] > 0,len = LengthWhile[K[[row = Last@Ordering@K]],# == 1 &];
   Do[AppendTo[R,eList[[row]]],{len}];
   K = Drop[#,len] & /@ K;
]

它的S33ѭ约为Sjoerd的方法的三倍。     ,我的解决方案是基于“贪婪是好的”的观察。如果我在中断一条链和开始一条新的可能较长的链之间做出选择，那么选择新的链来继续对我没有任何好处。新链变长，其数量与旧链变短。 因此，该算法的基本工作是从第一个子列表开始，并针对其每个成员查找具有相同成员的其他子列表的数量，然后选择具有最相邻双胞胎的子列表成员。然后，此过程在第一个链的末尾的子列表处继续，依此类推。 因此，将其结合到递归算法中，最终得到：

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,pickPath[lst[[lengthChoices[[bestElement]] + 1 ;; -1]]]
    }
   ]
  ]

测试

In[12]:= lst = 
 Table[RandomSample[Range[10],{8}]

Out[12]= {{3,5}}

In[13]:= pickPath[lst] // Flatten // AbsoluteTiming

Out[13]= {0.0020001,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,9}}}

我第一次使用略长的测试列表。蛮力方法使我的计算机陷入了虚拟停顿，声称拥有它的所有内存。很糟糕。我必须在10分钟后重新启动。重新启动又花了我25分钟的时间，这是因为PC变得非常无响应。     ,可以使用整数线性编程。这是代码。

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,c4];
  obj = Total[diffvars];
  res = Minimize[{obj,constraints},Integers];
  {res[[1]],Flatten[vars*lists /. res[[2]] /. 0 :> Sequence[]]}
 ]

你的例子：

lists = {{1,1}}

bestPick[lists]

Out [88] = {1，{2，2，1，1，1}} 对于较大的问题，Minimize可能会遇到麻烦，因为它使用精确的方法来解决宽松的LP。在这种情况下，您可能需要切换到NMinimize，并将domain参数更改为Element [fvars，Integers]形式的约束。 丹尼尔·里奇布劳     ,一周了！这是Carl Woll的寓言解决方案。 （我试图让他自己张贴它。卡尔，如果您遇到此问题并想获得官方认可，只需将其粘贴为单独的答案，然后我将其删除！）

pick[data_] := Module[{common,tmp},common = {};
  tmp = Reverse[If[(common = Intersection[common,#])=={},common = #,common]& /@
                data];
  common = .;
  Reverse[If[MemberQ[#,common],common,common = First[#]]& /@ tmp]]

仍引用Carl：   基本上，您从头开始，然后找到可以为您提供帮助的元素   最长的公共元素字符串。一旦字符串不能再被   扩展，开始一个新的字符串。在我看来，这种算法应该   给您一个正确的答案（有很多正确的答案）。