Wolfram mathematica 在Mathematica中使用带事例的PatternSequence查找峰值

给定坐标对

data = {{1, 0}, {2, 0}, {3, 1}, {4, 2}, {5, 1}, 
        {6, 2}, {7, 3}, {8, 4}, {9, 3}, {10, 2}}

我想提取峰谷，因此：

{{4, 2}, {5, 1}, {8, 4}}

我目前的解决方案是这样笨拙：

Cases[
 Partition[data, 3, 1],
 {{ta_, a_}, {tb_, b_}, {tc_, c_}} /; Or[a < b > c, a > b < c] :> {tb, b}
]

这将产生

{}

我认为该模式没有任何问题，因为它与

ReplaceAll

一起工作：

data /. ({___, PatternSequence[{_, a_}, {t_, b_}, {_, c_}], ___} 
             /; Or[a < b > c, a > b < c]) :> {t, b}

data/。（{{uuuuuuu，PatternSequence[{uuuuu，a}，{t}，b}，{uuu，c}]，{uuuu}
/；或[ac，a>b{t，b}

---

这给出了正确的第一个峰值，

{4，2}

。这到底是怎么回事？

这可能并不完全是您要求的实现，但大致如下：

ClearAll[localMaxPositions];
localMaxPositions[lst : {___?NumericQ}] := 
  Part[#, All, 2] &@
     ReplaceList[
        MapIndexed[List, lst], 
        {___, {x_, _}, y : {t_, _} .., {z_, _}, ___} /; x < t && z < t :> y];

获得位置后，可以提取元素：

In[4]:= Extract[test,%]
Out[4]= {9,20,18,20,16,20,18,15,12}

请注意，这也适用于plateau-s，其中一行中有多个相同的最大元素。要获得极小值，需要对代码进行简单的更改。实际上，我认为

ReplaceList

比

Cases

更好

要将其用于数据，请执行以下操作：

In[7]:= Extract[data,localMaxPositions[data[[All,2]]]]
Out[7]= {{4,2},{8,4}}

---

最小值也是一样。如果要合并，上述规则中的更改也很小。

失败尝试失败的原因之一是默认情况下，

案例

会在表达式的级别1上查找匹配项。由于您在0级上查找匹配项，因此需要执行以下操作

Cases[
 data,
 {___, {_, a_}, {t_, b_}, {_, c_}, ___} /; Or[a < b > c, a > b < c] :> {t, b}, 
 {0}
]

ReplaceList[data, ({___, {_, a_}, {t_, b_}, {_, c_}, ___} /; 
    Or[a < b > c, a > b < c]) :> {t, b}]

返回

{{4, 2}, {5, 1}, {8, 4}}

您的“笨拙”解决方案速度相当快，因为它严重限制了查看内容

这里有一个例子

m = 10^4;
n = 10^6;

ll = Transpose[{Range[n], RandomInteger[m, n]}];

In[266]:= 
Timing[extrema = 
    Cases[Partition[ll, 3, 
      1], {{ta_, a_}, {tb_, b_}, {tc_, c_}} /; 
       Or[a < b > c, a > b < c] :> {tb, b}];][[1]]

Out[266]= 3.88

In[267]:= Length[extrema]

Out[267]= 666463

这些方法不考虑连续等纵坐标的处理。这样做需要更多的工作，因为人们必须考虑大于三个连续元素的邻域。（我的拼写检查人员想让我在“邻居”的中间音节加上一个“u”。我的拼写检查人员一定认为我们在加拿大。）

Daniel Lichtblau

另一种选择：

Part[#,Flatten[Position[Differences[Sign[Differences[#[[All, 2]]]]], 2|-2] + 1]] &@data

(* ==> {{4, 2}, {5, 1}, {8, 4}} *)

Extract[#, Position[Differences[Sign[Differences[#]]], {_, 2} | {_, -2}] + 1] &@data

(* ==> {{4, 2}, {5, 1}, {8, 4}} *)

---

由于您对“笨拙”方法的主要关注之一是使用分区进行的数据扩展，因此您可能需要了解

Developer`

函数，它不会同时对所有数据进行分区。我使用

Sequence[]

删除我不想要的元素

Developer`PartitionMap[
  # /. {{{_, a_}, x : {_, b_}, {_, c_}} /; a < b > c || a > b < c :> x,
        _ :> Sequence[]} &,
  data, 3, 1
]

Developer`PartitionMap[
#/。{{{{{{}，a{}，x:{{{{}，b{}，{{{{u，c}}/；ac{124; a>bx，
_：>序列[]}&，
数据，3，1
]

欢迎来到StackOverflow ArgentoSapiens！请使用投票按钮对您喜欢的答案进行投票，不要忘记使用复选标记按钮接受您喜欢的答案作为最终答案。在执行此操作之前，您可能需要等待更多的答案。+1无需在

ReplaceList

表达式中的

PatternSequence

中包装内部序列。@Florach:是的，您是对的，这是原始代码的剩余部分。我将编辑我的答案。啊哈！

levelspec

是我所缺少的一部分。为什么“固定的”

案例

实现只返回第一个极值？@Sjoerd我的意思是plateau-s，这是一个输入错误。感谢你指出这一点，我无意侮辱柏拉图。+1，不知道《教区地图》。在很多情况下都很方便。@rcollyer-FWIW，我整理了我的答案。

In[268]:= Timing[ordinates = ll[[All, 2]];
  signs = 
   Table[Sign[(ordinates[[j + 1]] - 
        ordinates[[j]])*(ordinates[[j - 1]] - ordinates[[j]])], {j, 2,
      Length[ll] - 1}];
  extrema2 = Pick[ll[[2 ;; -2]], signs, 1];][[1]]

Out[268]= 0.23

In[269]:= extrema2 === extrema

Out[269]= True

Part[#,Flatten[Position[Differences[Sign[Differences[#[[All, 2]]]]], 2|-2] + 1]] &@data

(* ==> {{4, 2}, {5, 1}, {8, 4}} *)

Extract[#, Position[Differences[Sign[Differences[#]]], {_, 2} | {_, -2}] + 1] &@data

(* ==> {{4, 2}, {5, 1}, {8, 4}} *)

Developer`PartitionMap[
  # /. {{{_, a_}, x : {_, b_}, {_, c_}} /; a < b > c || a > b < c :> x,
        _ :> Sequence[]} &,
  data, 3, 1
]