Question

我遇到了Mathematica / StackOverflow人员可能会喜欢的一个老问题，这对于后代的StackOverflow来说似乎很有价值。

假设您有一个列表列表，并且您希望从每个列表中选择一个元素并将它们放在一个新列表中，以便最大化与其下一个邻居相同的元素数量。换句话说，对于结果列表l，最小化Length @ Split [l]。换句话说，我们希望列表具有相同连续元素的最少中断。

例如：

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

（或{3,3,1,1,1}同样好。）

这是一个荒谬的暴力解决方案：

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

其中argMax如下所述：
posmax: like argmax but gives the position(s) of the element x for which f[x] is maximal

你能想出更好的东西吗？传奇的卡尔沃尔为我做了这个，我会在一周内透露他的解决方案。

Answer 1

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

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

rl涉及的子集数量。

对于以这种方式生成的每个测试集，我让所有算法都做了他们的事情。我做了10次（使用相同的测试集），算法以随机顺序运行，以便平衡顺序效果和随机后台进程对我的笔记本电脑的影响。这导致给定数据集的平均时间。对于每个rl长度，使用上述线20次，从中计算平均值（平均值）和标准偏差。

结果如下（水平地表示子集的数量，垂直表示平均值AbsoluteTiming）：

enter image description here

似乎Mr.Wizard是（不太清楚）的赢家。恭喜！

<强>更新
正如Timo在此所要求的，时间是可以从每个子集中的元素的最大数量中选择的不同子集元素的数量的函数。根据这行代码生成固定数量的子集（50）的数据集：

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

我还为每个值尝试的数据集数量从20增加到40。

enter image description here

这里有5个子集：

enter image description here

Answer 2

我会把它扔进戒指。我不确定它总能提供最佳解决方案，但它看起来与其他一些答案的逻辑相同，而且速度很快。

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_, m_, _] := {x, m[[2]] + 1}

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

Answer 3

我的解决方案是基于这里“贪婪是好”的观察。如果我可以在中断链条和开始新的，可能很长的链条之间做出选择，选择新的链条继续对我没有好处。随着旧链变短，新链变得越来越长。

因此，该算法基本上做的是从第一个子列表开始，并为其每个成员查找具有相同成员的其他子列表的数量，并选择具有最邻近双胞胎的子列表成员。然后，此过程将在第一个链的末尾的子列表中继续，依此类推。

因此，在递归算法中将其结合起来我们最终得到：

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

Dreeves的蛮力方法

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

我第一次使用稍长的测试列表。蛮力的方法使我的计算机陷入虚拟停顿，声称它拥有所有的记忆。很糟糕。我不得不在10分钟后重新开始。由于PC变得非常无响应，重新启动又花了我四分之一。

Answer 4

这是我对它的看法，与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, 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}}

编辑鉴于 ~~Sjoerd的~~由于无法一次生成所有元组，Dreeves的暴力方法在大样本上失败，这是另一种蛮力方法：

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}

如果有人想要搜索像pickPath或LongestRuns这样的代码确实生成中断次数最少的序列的反例，我发布这个。

Answer 5

所以这是我的“单行班轮”，由Mr.Wizard改进：

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

我的2GHz Core 2 Duo上的Timing[]始终大约为0.032。

在这一点之下是我的第一次尝试，我将留下您的细读。

对于给定的元素列表M列表，我们计算不同的元素和列表的数量，按规范顺序列出不同的元素，并构造一个矩阵K[i,j]，详细说明元素的存在{列表i中的{1}}：

问题现在等同于从左到右遍历此矩阵，只需踩1，并尽可能少地更改行。

为实现此目的，我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个最多的行，跟踪我选择的元素，Sort来自Drop的许多列和重复：

其R = {}; While[Length@K[[1]] > 0, len = LengthWhile[K[[row = Last@Ordering@K]], # == 1 &]; Do[AppendTo[R, eList[[row]]], {len}]; K = Drop[#, len] & /@ K; ]约为Sjoerd's逼近的三倍。

Answer 6

这是一个... ...

runsByN：对于每个数字，显示每个子列表中是否显示

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

runsByN被list转置，插入零以表示缺失的数字。它显示了出现1,2,3和4的子列表。

myPick：挑选构成最佳路径的数字

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

感谢Mr.Wizard建议使用替换规则作为TakeWhile的有效替代方案。

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

下面的图表代表list的数据。每个绘制的点对应于一个数字和它所在的子列表。

Runs by n

Answer 7

可以使用整数线性编程。这是代码。

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]

Out [88] = {1，{2,2,1,1,1}}

对于较大的问题，Minimize可能会遇到麻烦，因为它使用精确的方法来解决松弛的LP。在这种情况下，您可能需要切换到NMinimize，并将domain参数更改为Element [fvars，Integers]形式的约束。

Daniel Lichtblau

Answer 8

一周了！以下是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]]

仍然引用卡尔：

基本上，你从头开始，找到给你的元素最长的共同元素串。一旦字符串不再可以扩展，开始一个新的字符串。在我看来，这个算法应该给你一个正确的答案（有很多正确答案）。

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

8 个答案:

runsByN：对于每个数字，显示每个子列表中是否显示

myPick：挑选构成最佳路径的数字

Epilog：可视化解决方案路径