Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

Is there a way in Mathematica to find the local maxima of a set of points?

Suppose you have

points={{xa,ya},{xb,yb},{xc,yc}...}

peakQ[{{x1_,y1_},{x2_,y2_},{x3_,y3_}}] := Abs[y1] > Abs[y2] && Abs[y2] < Abs[y3];
peaks=Map[#[[2]]&, Select[Partition[points,3,1],peakQ[#]&]]

Is it correct because in this way I find points but from plots I can see that I have lost some points.

share|improve this question
    
Could you make a concrete, numerical example to help clarify ? –  b.gatessucks Oct 24 '12 at 9:17
    
I feel your use of Abs is incorrect. Is there a reason to include them? –  Sjoerd C. de Vries Oct 24 '12 at 9:52
    
You could start by modifying the solutions in this question... –  J. M. Oct 24 '12 at 9:53
add comment

3 Answers

Here s another version to do it. First: some data

points = SortBy[RandomReal[1, {50, 2}], First]

This gives you the positions of the maxima and minima:

maxima = 1 + Position[Differences[Sign[Differences[points[[All, 2]]]]], -2]
minima = 1 + Position[Differences[Sign[Differences[points[[All, 2]]]]], 2]

peaks = Extract[points,maxima]

which you can see by plotting them:

ListLinePlot[points, Prolog -> {PointSize[Large], Red, Point[Extract[points, maxima]], Green, Point[Extract[points, minima]]}]

Mathematica graphics

How it works:

  • points[[All,2]] only takes the y-values

  • Sign[Differences[...]] takes the consecutive difference, and their Sign (i.e. -1, 0, or 1)

  • You are looking for something that goes up (+1) and down again (-1). So, we take Differences[...] again, and then look where the result is -2 (for maxima), or, equivalently, 2 (for minima). That is done with Position[...,2].

  • We have to add 1 because taking Differences makes the lists shorter

  • Extract[points,maxima] then gives you your results

And yet another version:

peaks = Pick[points[[2 ;; -2]], Differences[Sign[Differences[points[[All, 2]]]]], -2]

...with the same rationale as above, but using the functionality of Pick. One needs to drop the first and the last entry of points so that it has the same length as the other list.

Timing comparisons:

points = SortBy[RandomReal[1, {10^6, 2}], First];

peakQ[{{x1_, y1_}, {x2_, y2_}, {x3_, y3_}}] := y1 < y2 && y2 > y3
Timing[peaks1 = Select[Partition[points, 3, 1], peakQ][[All, 2]];]
(* 4 sec *)
Timing[peaks2 = Extract[points, 1 + Position[Differences[Sign[Differences[points[[All, 2]]]]], -2]];]
(* 0.4 sec *)
Timing[peaks3 = Pick[points[[2 ;; -2]], Differences[Sign[Differences[points[[All, 2]]]]], -2];]
(* 0.1 sec *)

peaks1 == peaks2 == peaks3
(* True *)
share|improve this answer
add comment

You can do a search for extrema (differential calculus), on the interpolated version of your dataset. See how to get an interpolated function from a set of data points here. The simplest way (assuming you have polynomial data) is to do a polynomial fit over points:

points = {
 {-5., 365.}, {-4.951, 356.571}, {-4.804, 331.998}, {-1.888, 38.604},
 {-0.018, -0.033}, {2.565, 54.056}, {3.285, 79.016}, {6.3, 159.451},
 {6.459, 160.646}, {6.715, 161.555}, {6.839, 161.524}, {7.06, 160.659},
 {8.971, 100.783}, {10.901, -85.324}, {15., -1095.}
 }; (* points sampled from -x^3 + 10 x^2 + 2 x *)

fit = Fit[points, {1, x, x^2, x^3}, x];
f = Function[{x}, Evaluate@fit]

f[x]
0.00401351 + 2.00137 x + 9.99945 x^2 - 0.999973 x^3

Afterwards, you can get the derivative of your curve, f. The function f is our fitted polynomial function:

Plot[{f[x], f'[x], f''[x]}, {x, -5, 15}]

Mathematica graphics

Where the first derivative is zero the function has a stationary point:

sol = NSolve[{f'[x] == 0}, x, Reals]

{{x -> -0.0986535}, {x -> 6.76506}}

Checking the second derivative tells whether at the given point of interest f has a minimum or maximum (or f[x] is an inflection point):

f''[x] /. sol

{20.5912, -20.5912}

where:

  • $f^{\prime\prime}(x) < 0$ -> $f$ has a local maximum at $x$.
  • $f^{\prime\prime}(x) > 0$ -> $f$ has a local minimum at $x$.
  • $f^{\prime\prime}(x) = 0$ -> $f$ has an inflection point at $x$

Thus:

minmax = MapThread[# -> 
   Which[#2 < 0, "max", #2 > 0, "min", True, "inflection"] &, {x /. 
   sol, f''[x] /. sol}]

{-0.0986535 -> "min", 6.76506 -> "max"}

Plot[{f[x], f'[x]}, {x, -5, 15}, 
 Epilog -> {AbsolutePointSize@5, Red, 
   Point[{#, f[#]} & /@ (x /. sol)], Black, 
   Text[Last@#, {First@#, f@First@#}, {-1, 1}] & /@ minmax}]

Mathematica graphics

share|improve this answer
add comment

A solution based on code from giacomo's question, assuming that points have distinct $x$-coordinates.

In[1]:= points=SortBy[RandomReal[1,{10,2}],First]
Out[1]= {{0.0120925,0.643074},{0.180014,0.667626},{0.250923,0.696545},{0.332885,0.0217103},{0.374107,0.13732},{0.444013,0.0420624},{0.45527,0.706021},{0.547433,0.454037},{0.852822,0.897056},{0.903773,0.112657}}

As Sjoerd pointed out, we do not need to use Abs. I think you need to switch the inequalities if you want the local maximum points.

In[2]:= peakQ[{{x1_,y1_},{x2_,y2_},{x3_,y3_}}]:=y1<y2 && y2>y3

We can simply use peakQ as opposed to peakQ[#]& in Select.

In[3]:= peaks=Select[Partition[points,3,1],peakQ][[All,2]]
Out[3]= {{0.250923,0.696545},{0.374107,0.13732},{0.45527,0.706021},{0.852822,0.897056}}
share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.