在 Mathematica 中查找相似但不相同的元素

Question

我有一个数字列表。我想从列表中提取属于某个范围内且具有一定最小长度的数字。例如，假设我想对此列表进行操作：

thisList = {-1.2, -1.8, 1.5, -0.6, -0.8, -0.1, 1.4, -0.3, -0.1, -0.7}

使用 band=1 和 runLength=3。我想要

{{-0.6, -0.8, -0.1}, {-0.3, -0.1, -0.7}}

这样的结果。现在我正在使用

Cases[
 Partition[thisList,runLength,1],
 x_ /; Abs[Max[x] - Min[x]] < band
]

主要问题是在运行重叠的地方，我得到了运行的许多副本。例如，使用

thisList = {-1.2, -1.8, 1.5, -0.6, -0.8, -0.1, -0.5, -0.3, -0.1, -0.7}

为我提供了

{{-0.6, -0.8, -0.1}, {-0.8, -0.1, -0.5}, {-0.1, -0.5, -0.3}, {-0.5, -0.3, -0.1}, {-0.3, -0.1, -0.7}}

我宁愿拥有的地方，

{-0.6, -0.8, -0.1, -0.5, -0.3, -0.1, -0.7}

而无需对重叠结果进行一些做作的减少。正确的方法是什么？如果不涉及使用 Partition 分解数据，那就太好了。

Answer 1

编辑

显然，我的第一个解决方案至少有两个严重缺陷：它非常慢并且对于超过 100 个元素的列表完全不切实际，并且它包含一些我无法识别的错误然而 - 有时会缺少一些乐队。因此，我将提供两种（希望是正确的）且更有效的替代方案，并且我为任何感兴趣的人提供下面有缺陷的替代方案。

基于链表的解决方案

下面是一个基于链表的解决方案。它允许我们仍然使用模式，但避免由包含 __ 或 ___ 的模式导致的低效率（重复应用时）：

ClearAll[toLinkedList];
toLinkedList[x_List] := Fold[{#2, #1} &, {}, Reverse@x]

ClearAll[accumF];
accumF[llFull_List, acc_List, {h_, t_List}, ctr_, max_, min_, band_, rLen_] :=
  With[{cmax = Max[max, h], cmin = Min[min, h]},
     accumF[llFull, {acc, h}, t, ctr + 1, cmax, cmin, band, rLen] /; 
        Abs[cmax - cmin] < band];
accumF[llFull_List, acc_List, ll : {h_, _List}, ctr_, _, _, band_, rLen_] /; ctr >= rLen :=
     accumF[ll, (Sow[acc]; {}), ll, 0, h, h, band, rLen];
accumF[llFull : {h_, t : {_, _List}}, _List, ll : {head_, _List}, _, _, _, band_, rLen_] :=
     accumF[t, {}, t, 0, First@t, First@t, band, rLen];
accumF[llFull_List, acc_List, {}, ctr_, _, _, _, rLen_] /; ctr >= rLen := Sow[acc];

ClearAll[getBandsLL];
getBandsLL[lst_List, runLength_Integer, band_?NumericQ] :=
  Block[{$IterationLimit = Infinity},
     With[{ll = toLinkedList@lst},
        Map[Flatten,
          If[# === {}, #, First@#] &@
            Reap[
              accumF[ll, {}, ll, 0, First@ll, First@ll, band,runLength]
            ][[2]]
        ]
     ]
  ];

以下是使用示例：

In[246]:= getBandsLL[{-1.2,-1.8,1.5,-0.6,-0.8,-0.1,1.4,-0.3,-0.1,-0.7},3,1]
Out[246]= {{-0.6,-0.8,-0.1},{-0.3,-0.1,-0.7}}

In[247]:= getBandsLL[{-1.2,-1.8,1.5,-0.6,-0.8,-0.1,-0.5,-0.3,-0.1,-0.7},3,1]
Out[247]= {{-0.6,-0.8,-0.1,-0.5,-0.3,-0.1,-0.7}}

函数的主要思想 < code>accumF 是遍历数字列表（之前转换为链表），并在另一个链表中累加一个 band，并将其作为第二个参数传递给它。一旦 band 条件失败，就会使用 Sow 存储累积的 band（如果它足够长），并且该过程从链表的剩余部分重新开始。如果我们选择使用 Depth[acc] 来代替，则可能不需要 ctr 参数。

上面的代码中有一些不明显的东西。一个微妙的点是，尝试将accumF的两个中间规则连接到单个规则中（它们看起来非常相似）并使用CompoundExpression（类似于(If rhs 上的 [ctr>=rLen, Sow[acc];accumF[...])) 将导致非尾递归 accumF （参见 这个答案对这个问题进行更详细的讨论这也是我的原因。在函数调用中添加 (Sow[acc]; {}) 行 - 以避免在 rhs 上使用顶级 CompoundExpression）。另一个微妙的点是，我必须在找到最后一个成功匹配后立即维护包含剩余元素的链接列表的副本，因为在序列不成功的情况下，我需要回滚到该列表减去其第一个元素，然后开始超过。该链表存储在accumF 的第一个参数中。

请注意，传递大型链表的成本并不高，因为复制的只是第一个元素（头）和指向其余元素（尾）的指针。与 {___,x__,right___} 等模式的情况相比，这是使用链表极大提高性能的主要原因 - 因为在后一种情况下，完整的序列 x< /code> 或 right 被复制。使用链表，我们实际上只复制一些引用，因此我们的算法的行为大致如我们所期望的那样（此处与数据列表的长度呈线性关系）。在这个答案中，我还提到了在以下情况下使用链表：优化代码的技术之一（第 3.4 节）。

基于编译的解决方案

这是一个基于 Compile 的简单但不太优雅的函数，它查找列表中的起始和结束带位置列表：

bandPositions = 
  Compile[{{lst, _Real, 1}, {runLength, _Integer}, {band, _Real}},
   Module[{i = 1, j, currentMin, currentMax, 
        startEndPos = Table[{0, 0}, {Length[lst]}], ctr = 0},
    For[i = 1, i <= Length[lst], i++,
      currentMin = currentMax = lst[[i]];
      For[j = i + 1, j <= Length[lst], j++,
        If[lst[[j]] < currentMin,
           currentMin = lst[[j]],
           (* else *)
           If[lst[[j]] > currentMax,
             currentMax = lst[[j]]
           ]
        ];
        If[Abs[currentMax - currentMin] >= band ,
          If[ j - i >= runLength,
             startEndPos[[++ctr]] = {i, j - 1}; i = j - 1
          ];
          Break[],
          (* else *)
          If[j == Length[lst] && j - i >= runLength - 1,
              startEndPos[[++ctr]] = {i, j}; i = Length[lst];
              Break[];
          ];
        ]
      ]; (* inner For *)
    ]; (* outer For *)
    Take[startEndPos, ctr]], CompilationTarget -> "C"];

这在最终函数中使用：

getBandsC[lst_List, runLength_Integer, band_?NumericQ] :=
   Map[Take[lst, #] &, bandPositions[lst, runLength, band]]

使用示例：

In[305]:= getBandsC[{-1.2,-1.8,1.5,-0.6,-0.8,-0.1,1.4,-0.3,-0.1,-0.7},3,1]
Out[305]= {{-0.6,-0.8,-0.1},{-0.3,-0.1,-0.7}}

In[306]:= getBandsC[{-1.2,-1.8,1.5,-0.6,-0.8,-0.1,-0.5,-0.3,-0.1,-0.7},3,1]
Out[306]= {{-0.6,-0.8,-0.1,-0.5,-0.3,-0.1,-0.7}}

基准测试

In[381]:= 
largeTest  = RandomReal[{-5,5},50000];
(res1 =getBandsLL[largeTest,3,1]);//Timing
(res2 =getBandsC[largeTest,3,1]);//Timing
res1==res2

Out[382]= {1.109,Null}
Out[383]= {0.016,Null}
Out[384]= True

显然，如果想要性能，Compile 无疑会胜出。我对较大列表的观察是，这两种解决方案都具有与数字列表的大小近似线性的复杂性（正如它们应该的那样），在我的机器上编译的解决方案比基于链接列表的解决方案快大约 150 倍。

备注

事实上，两种方法都编码相同的算法，尽管这可能并不明显。具有递归和模式的可以说更容易理解，但这是一个观点问题。

一个简单但缓慢且有错误的版本

这是我首先编写的用于解决此问题的原始代码。这是基于相当简单的模式使用和重复规则应用。如前所述，该方法的一个缺点是其性能非常差。这实际上是反对将 {___,x__,y___} 等结构与重复规则应用结合使用的另一种情况，适用于任何长度超过几十个元素的情况。在提到的代码优化技术建议中，这对应于第4.1节。

无论如何，这是代码：

If[# === {}, #, First@#] &@
 Reap[thisList //. {
    left___, 
    Longest[x__] /;Length[{x}] >= runLength && Abs[Max[{x}] - Min[{x}]] < band,
    right___} :> (Sow[{x}]; {right})][[2]]

它对于两个原始的小测试列表都可以正常工作。它看起来总体上是正确的，但对于较大的列表，它经常会错过一些带，这可以通过与其他两种方法进行比较来看出。到目前为止，我还无法定位该错误，因为代码看起来相当透明。

Answer 2

我会尝试这样做：

thisList /. {___, Longest[a : Repeated[_, {3, Infinity}]], ___} :> 
               {a} /; Abs[Max@{a} - Min@{a}] < 1

其中 Repeated[_, {3, Infinity}] 保证您至少获得 3 个术语，而 Longest 确保它为您提供最长的运行时间可能的。作为一个函数，

Clear[f]
f[list_List, band_, minlen_Integer?Positive] := f[list, band, minlen, Infinity]
f[list_List, band_, 
  minlen_Integer?Positive, maxlen_?Positive] /; maxlen >= minlen := 
 list /. {___, Longest[a : Repeated[_, {minlen, maxlen}]], ___} :> {a} /; 
    Abs[Max@{a} - Min@{a}] < band

Answer 3

给出了非常复杂的答案。 :-) 我想我有一个更简单的方法给你。自己定义相似性对您意味着什么，并使用 GatherBy[] 收集所有相似元素，或使用 SplitBy[] 收集相似元素的“runs”（然后删除“运行”的最小不可接受长度，例如 1 或 2，通过 DeleteCases[]）。

更难的问题是建立相似性。按照你的方法 1.2,0.9,1.9,0.8 会将前三个元素分组，但不会将后三个元素分组，但 0.9 和 0.8 同样相似，1.9 会将其从你的乐队中踢出。 .4,.5,.6,.7,.8,.9,1.0,1.1,1.2,1.3,1.4,1.5 呢？相似性在哪里结束？

另请查看 ClusteringComponents[] 和 FindClusters[]