PatternSequence con casos en Mathematica para encontrar picos

Question

pares de coordenadas dado

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

me gustaría extraer picos y valles, por lo tanto:

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

Mi solución actual es esta torpeza:

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

que se puede ver al comenzar triplicando el tamaño del conjunto de datos usando Partition . Creo que es posible utilizar Cases y PatternSequence para extraer esta información, pero este intento no funciona:

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

que los rendimientos {}.

No creo que algo está mal con el patrón, ya que funciona con ReplaceAll:

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

que da el primer pico correcta, {4, 2}. ¿Que está pasando aqui?

Answer 1

Uno de los motivos por los que su intento fallido no funciona es que Cases busca de manera predeterminada coincidencias en el nivel 1 de su expresión. Desde su buscar coincidencias en el nivel 0 que tendría que hacer algo como

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

Sin embargo, esto sólo devuelve {4,2} como una solución por lo que todavía no es lo que está buscando. para encontrar todos los partidos sin particionar que podría hacer algo como

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

que devuelve

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

Answer 2

Esto no puede ser exactamente la puesta en práctica de preguntar, pero en ese sentido:

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

Ejemplo:

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

Una vez que tenga posiciones, es posible extraer los elementos:

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

Tenga en cuenta que esto también funcionará para plateau-s donde tiene más de un mismo elemento máximo en un ro w. Para obtener mínimos, uno necesita cambiar trivialmente el código. De hecho, creo que ReplaceList es una mejor opción que Cases aquí.

Para utilizarlo con sus datos:

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

y lo mismo para los mínimos. Si desea combinar, el cambio en la regla anterior también es trivial.

Answer 3

Su solución "torpe" es bastante rápido, ya que restringe fuertemente lo que se miraba.

Aquí hay un ejemplo.

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 

Esto parece ser más rápido que utilizar reglas de reemplazo.

Más rápido aún es crear una tabla de signos de productos de diferencias. A continuación, elija las entradas no en los extremos de la lista que corresponden a productos de firmar 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 

Manipulación de ordenadas iguales consecutivos no se considera en estos métodos. Hacer eso requeriría más trabajo ya que uno debe considerar los barrios con más de tres elementos consecutivos. (. Mi corrector ortográfico quiere que añada una 'U' a la sílaba medio de "barrios" Mi corrector ortográfico debe pensar que estamos en Canadá.)

Daniel Lichtblau

Answer 4

Otra alternativa:

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 5

Dado que una de sus principales preocupaciones acerca de su método "torpe" es la expansión de datos que tiene lugar con Partition, puede interesarle conocer la función Developer`PartitionMap, que no divide todos los datos a la vez. Uso Sequence[] para eliminar los elementos que no quiero.

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