Utilizzando PatternSequence i casi in Mathematica per trovare picchi

Question

coppie di coordinate di

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

vorrei estrarre picchi e valli, in tal modo:

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

mia soluzione attuale è questa goffaggine:

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

che potete vedere inizia triplicando le dimensioni del set di dati utilizzando Partition . Penso che sia possibile utilizzare Cases e PatternSequence per estrarre queste informazioni, ma questo tentativo non funziona:

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

che produce {}.

Non credo che qualcosa è sbagliato con il modello perché funziona con ReplaceAll:

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

che dà la giusta primo picco, {4, 2}. Cosa sta succedendo qui?

Answer 1

Uno dei motivi per cui il tentativo fallito non funziona è che per impostazione predefinita Cases cerca corrispondenze al livello 1 dell'espressione. Dal momento che la vostra ricerca di partite a livello 0 si avrebbe bisogno di fare qualcosa di simile

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

Tuttavia, questo restituisce solo {4,2} come soluzione quindi non è ancora quello che stai cercando. Per trovare tutte le partite senza partizionamento si potrebbe fare qualcosa di simile

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

che restituisce

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

Answer 2

Questo potrebbe non essere esattamente l'attuazione si chiede, ma in questo senso:

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

Esempio:

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 volta che avete posizioni, è possibile estrarre gli elementi:

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

Si noti che questo funzionerà anche per plateau-s dove si ha più di uno stesso elemento massimale in un ro w. Per ottenere i minimi, è necessario cambiare banalmente il codice. In realtà penso che ReplaceList sia una scelta migliore di Cases qui.

Per usarlo con i tuoi dati:

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

e lo stesso per i minimi. Se si desidera combinare, anche la modifica della regola precedente è banale.

Answer 3

La soluzione "maldestra" è abbastanza veloce, perché limita pesantemente ciò che viene guardato.

Ecco un esempio.

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 

Questo sembra essere più veloce rispetto all'utilizzo di regole di sostituzione.

Ancora più veloce è creare una tabella di segni di prodotti di differenze. Poi scegliere voci non sulle estremità della lista che corrispondono ai prodotti di firmare 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 

Gestione delle ordinate pari consecutive non è considerata in questi metodi. Fare ciò richiederebbe più lavoro dal momento che si devono considerare i quartieri più grandi di tre elementi consecutivi. (. Il mio correttore ortografico mi vuole aggiungere un 'u' per la sillaba centrale di "quartieri" Il mio correttore ortografico deve pensare che siamo in Canada.)

Daniel Lichtblau

Answer 4

Un'altra 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

Poiché uno dei tuoi principali dubbi sul metodo "maldestro" è l'espansione dei dati che avviene con Partition, potresti voler conoscere la funzione Developer`PartitionMap, che non partiziona tutti i dati contemporaneamente. Io uso Sequence[] per eliminare gli elementi che non desidero.

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