Использование PatternSequence с Cases в Mathematica для поиска пиков

Question

Учитывая пары координат

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

, который вы видите, начинается с трехкратного увеличения размера набора данных с помощью Partition.Я думаю, что можно использовать Cases и PatternSequence для извлечения этой информации, но эта попытка не работает:

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

Это дает {}.

Я неЯ не думаю, что с шаблоном что-то не так, потому что он работает с ReplaceAll:

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

Это дает правильный первый пик, {4, 2}.Что здесь происходит?

Answer 1

Одна из причин, по которой ваша неудачная попытка не сработала, заключается в том, что Cases по умолчанию ищет совпадения на уровне 1 вашего выражения.Так как вы ищете совпадения на уровне 0, вам нужно будет сделать что-то вроде

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

Однако, это только возвращает {4,2} в качестве решения, так что это все еще не то, что вы ищете.Чтобы найти все совпадения без разбиения, вы можете сделать что-то вроде

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

, которое возвращает

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

Answer 2

Ваше "неуклюжее" решение довольно быстрое, потому что оно сильно ограничивает то, на что смотрят.

Вот пример.

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

Это кажется быстрее, чем использование правил замены.

Быстрее все же создать таблицу знаков различий. Затем выберите записи не в конце списка, которые соответствуют знаковым продуктам 1.

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

Обработка последовательных равных ординат в этих методах не рассматривается. Выполнение этого потребовало бы больше работы, так как нужно рассмотреть окрестности, превышающие три последовательных элемента. (Моя программа проверки орфографии хочет, чтобы я добавил «u» к среднему слогу «окрестности». Моя программа проверки орфографии должна думать, что мы находимся в Канаде.)

Даниэль Лихтблау

Answer 3

Другая альтернатива:

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

Answer 4

Это может быть не совсем та реализация, о которой вы спрашиваете, но по следующим направлениям:

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

Пример:

In[2]:= test = RandomInteger[{1,20},30]
Out[2]= {13,9,5,9,3,20,2,5,18,13,2,20,13,12,4,7,16,14,8,16,19,20,5,18,3,15,8,8,12,9}

In[3]:= localMaxPositions[test]
Out[3]= {{4},{6},{9},{12},{17},{22},{24},{26},{29}}

Когда у вас есть позиции, вы можете извлечь элементы:

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

Обратите внимание, что это также будет работать для плато, где у вас есть более одного максимального элемента в строке. Чтобы получить минимумы, нужно тривиально изменить код. Я действительно считаю, что ReplaceList - лучший выбор, чем Cases здесь.

Чтобы использовать это с вашими данными:

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

и то же самое для минимумов. Если вы хотите объединить, изменение в вышеуказанном правиле также тривиально.

Answer 5

Поскольку одной из ваших основных проблем в отношении вашего "неуклюжего" метода является расширение данных, которое происходит с разделом, вам может потребоваться информация о функции Developer` PartitionMap, которая не разбивает разделывсе данные сразу.Я использую Sequence[], чтобы удалить ненужные элементы.

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