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

时间：2011-12-13 19:32:18

标签： wolfram-mathematica

我有一个数字列表。我想从列表中提取出一些属于某些波段并具有一些最小长度的数字。例如，假设我想在此列表上操作：

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爆炸数据，那就太好了。

3 个答案:

答案 0 :(得分：6)

编辑

显然，我的第一个解决方案至少有两个严重的缺陷：对于大于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}}

函数accumF的主要思想是遍历数字列表（转换为之前的链表），并在另一个链表中累积一个带，作为第二个参数传递给它。一旦波段条件失败，使用Sow（如果足够长）记忆累积的波段，并且该过程从链表的剩余部分开始。如果我们选择使用ctr，则可能不需要Depth[acc]参数。

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

请注意，传递大型链接列表的成本并不高，因为复制的只是第一个元素（头部）和指向其余部分（尾部）的指针。与{___,x__,right___}等模式的情况相比，这是使用链表大大提高性能的主要原因 - 因为在后一种情况下，会复制完整序列x或right。对于链表，我们实际上只复制了一些引用，因此我们的算法的行为与我们期望的大致相似（这里的数据列表的长度是线性的）。在this answer中，我还提到在这种情况下使用链表作为优化代码的技术之一（第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___}这样的结构和重复的规则应用程序，对于任何超过几十个元素的东西。在上面提到的recommendations for code optimization techniques中，这对应于4.1节。

无论如何，这是代码：

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

它适用于两个原始的小测试列表。它也看起来通常是正确的，但对于较大的列表，它经常错过一些频段，这可以通过与其他两种方法的比较看出。我没有能够本地化这个bug，因为代码看起来非常透明。

答案 1 :(得分：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

答案 2 :(得分：0)

给出非常复杂的答案。 :-)我想我有一个更简单的方法。自己定义相似性对你来说意味着什么，并使用GatherBy[]收集所有相似元素，或SplitBy[]收集类似元素的“运行”（然后删除最小未接受长度的“运行”，比如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[]

相关问题
最新问题