Maxima & Minima
nilaakash
Suppose I have some points. If you plot these points
you will see there are few maxima and minima. I want to find only
those maxima and minima points. Is there any process to findout only
those max & min coordinates. (both x & y points).
data={{0.5, 1.30301}, {0.51, 1.30244}, {0.52, 1.30533}, {0.53,
1.3059}, {0.54,
1.30544}, {0.55, 1.30816}, {0.56, 1.30942}, {0.57, 1.30952},
{0.58,
1.31146}, {0.59, 1.31105}, {0.6, 1.31357}, {0.61, 1.31614}, {0.62,
1.31636}, {0.63, 1.31782}, {0.64, 1.31977}, {0.65, 1.31993},
{0.66,
1.32175}, {0.67, 1.32041}, {0.68, 1.32705}, {0.69, 1.33001}, {0.7,
1.33689}, {0.71, 1.34665}, {0.72, 1.35868}, {0.73, 1.37899},
{0.74,
1.40351}, {0.75, 1.44677}, {0.76, 1.49938}, {0.77, 1.56417},
{0.78,
1.6265}, {0.79, 1.68231}, {0.8, 1.73439}, {0.81, 1.77567}, {0.82,
1.79751}, {0.83, 1.81008}, {0.84, 1.80272}, {0.85, 1.78359},
{0.86,
1.74827}, {0.87, 1.69779}, {0.88, 1.63964}, {0.89, 1.57302}, {0.9,
1.49157}, {0.91, 1.40873}, {0.92, 1.32168}, {0.93, 1.22632},
{0.94,
1.12993}, {0.95, 1.03509}, {0.96, 0.940307}, {0.97, 0.843889},
{0.98,
0.750626}, {0.99, 0.658783}, {1., 0.571786}, {1.01, 0.490484},
{1.02,
0.414139}, {1.03, 0.342955}, {1.04, 0.27755}, {1.05, 0.219544},
{1.06,
0.169213}, {1.07, 0.126781}, {1.08, 0.091582}, {1.09, 0.0642237},
{1.1,
0.0444826}, {1.11, 0.0324386}, {1.21, 0.17094}, {1.31, 0.721742},
{1.41,
1.17931}, {1.51, 1.49921}, {1.61, 1.67064}, {1.71, 1.72145},
{1.81,
1.69853}, {1.91, 1.6343}, {2.01, 1.54399}, {2.11, 1.45614}, {2.21,
1.36254}, {2.31, 1.27609}, {2.41, 1.19319}, {2.51, 1.12123},
{2.61,
1.04736}, {2.71, 0.98465}, {2.81, 0.925526}, {2.91, 0.871404},
{3.01,
0.821615}, {3.11, 0.77698}, {3.21, 0.732385}, {3.31, 0.693622},
{3.41,
0.655827}, {3.51, 0.623108}, {3.61, 0.591913}, {3.71, 0.562528},
{3.81,
0.534357}, {3.91, 0.50876}, {4.01, 0.484918}, {4.11, 0.463476},
{4.21,
0.441866}, {4.31, 0.422324}, {4.41, 0.4049}, {4.51, 0.387806},
{4.61,
0.371429}, {4.71, 0.356785}, {4.81, 0.3418}, {4.91, 0.328734}}
Thanks
nilaakash
DrBob
data[[1+Flatten@Position[Partition[data[[All, 2]], 3, 1], {a_, b_,
c_} /; b < Min[a, c] || b > Max[a, c]]]]
{{0.51, 1.30244},
{0.53, 1.3059},
{0.54, 1.30544},
{0.58, 1.31146},
{0.59, 1.31105},
{0.66, 1.32175},
{0.67, 1.32041},
{0.83, 1.81008},
{1.11, 0.0324386},
{1.71, 1.72145}}
(Too many, if we assume the data is only approximate.)
Here's another method:
{min, max} = Through[{Min, Max}@data[[All, 1]]];
f = Interpolation[data];
Plot[{f@x, f'@x}, {x, min, max}]
Off[InterpolatingFunction::"dmval"]
FindRoot[f'[x] == 0, {x, #}] & /@ {min, 1, 2}
{{x -> 0.505531}, {x -> 1.12307}, {x -> 1.7219}}
{x, f@x} /. %
{{0.5055312156861533, 1.301922579278834},
{1.1230689459629595, 0.027059539216569332},
{1.7218962023425761, 1.721953518594516}}
(That misses the first maximum rather badly.)
And a third method:
<<NumericalMath`InterpolateRoot`
InterpolateRoot[f'@x == 0, {x, min, 1}]
InterpolateRoot[f'@x == 0, {x, 1, 1.5}]
InterpolateRoot[f'@x == 0, {x, 1.5, max}]
{x -> 0.52857394991751015071728945637877314465`23.723105755682077}
{x -> 1.72189620234257605782273932854817383567`22.23600696819283}
{x -> 5.09205275261335446811354032880462993659`22.706892894205932}
(That misses both maxima.)
So all three methods have their problems, obviously.
Finally, here's a modification of the first method, in which I rely on the ListPlot to suggest there should be two maxima and one minimum, and select (in an admittedly primitive sense) the most prominent features that qualify. The idea is to ignore tiny peaks and valleys the first method zooms in on.
First the minimum:
delta1 = Max@
Cases[Partition[data[[All, 2]], 3, 1], {a_,
b_, c_} /; b < Min[a, c] :> Min[a, c] - b];
data[[1 + Flatten@Position[Partition[data[[All, 2]], 3, 1], {a_, b_,
c_} /; b ≤ Min[a, c] - delta1]]]
{{1.11, 0.0324386}}
And the maxima:
delta2 = Sort[
Cases[Partition[data[[All,
2]], 3, 1], {a_, b_, c_} /; b > Max[a, c] :> b - Max[a,
c]]][[-2]];
data[[1 + Flatten@Position[Partition[data[[All, 2]], 3, 1], {
a_, b_, c_} /; b ≥ Max[a, c] + delta2]]]
{{0.83, 1.81008},
{1.71, 1.72145}}
All in all, that looks like the best answer of the four.
Analysis of this kind with a finite sample is always iffy, of course.
Bobby
yehuda ben-shimol
Also note that there is also local minima and maxima.
So,
The position of (local) maximal points are
maxpositions=Flatten[Position[Ordering[#, -1] & /@ Partition[Last /@
data, 3, 1], {2}]] + 1
that in your case are the positions
{4, 9, 17, 34, 68}
The values of data of these points are given by
data[[maxpositions]]
and these are
{{0.53, 1.3059}, {0.58, 1.31146}, {0.66, 1.32175}, {0.83, 1.81008}, {1.71, \
1.72145}}
Similarly for (local) minima points
minpositions=Flatten[Position[Ordering[#, 1] & /@ Partition[Last /@
data, 3, 1], {2}]] + 1
that in your case are the positions
{2, 5, 10, 18, 62}
The values of data of these points are given by
data[[minpositions]]
and these are
{{0.51, 1.30244}, {0.54, 1.30544}, {0.59, 1.31105}, {0.67, 1.32041}, {
1.11, 0.0324386}}
yehuda
Bob Hanlon
{0.52,1.30533},{0.53,1.3059},
{0.54,1.30544},{0.55,1.30816},
{0.56,1.30942},{0.57,1.30952},
{0.58,1.31146},{0.59,1.31105},
{0.6,1.31357},{0.61,1.31614},
{0.62,1.31636},{0.63,1.31782},
{0.64,1.31977},{0.65,1.31993},
{0.66,1.32175},{0.67,1.32041},
{0.68,1.32705},{0.69,1.33001},
{0.7,1.33689},{0.71,1.34665},
{0.72,1.35868},{0.73,1.37899},
{0.74,1.40351},{0.75,1.44677},
{0.76,1.49938},{0.77,1.56417},
{0.78,1.6265},{0.79,1.68231},
{0.8,1.73439},{0.81,1.77567},
{0.82,1.79751},{0.83,1.81008},
{0.84,1.80272},{0.85,1.78359},
{0.86,1.74827},{0.87,1.69779},
{0.88,1.63964},{0.89,1.57302},
{0.9,1.49157},{0.91,1.40873},
{0.92,1.32168},{0.93,1.22632},
{0.94,1.12993},{0.95,1.03509},
{0.96,0.940307},{0.97,0.843889},
{0.98,0.750626},{0.99,0.658783},
{1.,0.571786},{1.01,0.490484},
{1.02,0.414139},{1.03,0.342955},
{1.04,0.27755},{1.05,0.219544},
{1.06,0.169213},{1.07,0.126781},
{1.08,0.091582},{1.09,0.0642237},
{1.1,0.0444826},{1.11,0.0324386},
{1.21,0.17094},{1.31,0.721742},
{1.41,1.17931},{1.51,1.49921},
{1.61,1.67064},{1.71,1.72145},
{1.81,1.69853},{1.91,1.6343},
{2.01,1.54399},{2.11,1.45614},
{2.21,1.36254},{2.31,1.27609},
{2.41,1.19319},{2.51,1.12123},
{2.61,1.04736},{2.71,0.98465},
{2.81,0.925526},{2.91,0.871404},
{3.01,0.821615},{3.11,0.77698},
{3.21,0.732385},{3.31,0.693622},
{3.41,0.655827},{3.51,0.623108},
{3.61,0.591913},{3.71,0.562528},
{3.81,0.534357},{3.91,0.50876},
{4.01,0.484918},{4.11,0.463476},
{4.21,0.441866},{4.31,0.422324},
{4.41,0.4049},{4.51,0.387806},
{4.61,0.371429},{4.71,0.356785},
{4.81,0.3418},{4.91,0.328734}};
xmin=Min[data[[All,1]]];
xmax=Max[data[[All,1]]];
id = Interpolation[data];
Plot[id[x],{x,xmin,xmax},
PlotRange->{{Floor[xmin],Ceiling[xmax]},Automatic}];
Off[InterpolatingFunction::dmval];
idPeaks=({x,id[x]} /.
(FindRoot[D[id[x],x]==0,{x,#}]& /@
{0.9,1.1,2.}))
{{0.8306328862190794, 1.8101192247875528},
{1.123068945962959, 0.027059539216569357},
{1.7218962023425761, 1.721953518594516}}
dataPeaks=Table[Sort[data,
Abs[#1[[2]]-idPeaks[[k,2]]]<
Abs[#2[[2]]-idPeaks[[k,2]]]&][[1]],
{k,Length[idPeaks]}]
{{0.83, 1.81008}, {1.11, 0.0324386}, {1.71, 1.72145}}
Bob Hanlon
Ray Koopman
> Here's a complete list of local extrema in the raw data:
>
> data[[1+Flatten@Position[Partition[data[[All, 2]], 3, 1],
> {a_, b_, c_} /; b < Min[a, c] || b > Max[a, c]]]]
>
> {{0.51, 1.30244},
> {0.53, 1.3059},
> {0.54, 1.30544},
> {0.58, 1.31146},
> {0.59, 1.31105},
> {0.66, 1.32175},
> {0.67, 1.32041},
> {0.83, 1.81008},
> {1.11, 0.0324386},
> {1.71, 1.72145}}
>
> (Too many, if we assume the data is only approximate.)
That approach works fine (at least with this data) if we widen the
window and look more than one point to the left and right:
With[{k = 2},
data[[k + Flatten@Position[Partition[data[[All,2]],2k+1,1], x_List /;
x[[k+1]] < Min[Delete[x,k+1]] || x[[k+1]] > Max[Delete[x,k+1]]]]]]
will ignore the glitches and give
{{0.83,1.81008},{1.11,0.0324386},{1.71,1.72145}}
DrBob
(But we don't really know if the glitches ARE glitches, of course.)
Bobby
On Wed, 26 Jan 2005 04:37:09 -0500 (EST), Ray Koopman <koo...@sfu.ca> wrote:
> DrBob wrote:
>> Here's a complete list of local extrema in the raw data:
>>
>> data[[1+Flatten@Position[Partition[data[[All, 2]], 3, 1],
>> {a_, b_, c_} /; b < Min[a, c] || b > Max[a, c]]]]
>>
>> {{0.51, 1.30244},
>> {0.53, 1.3059},
>> {0.54, 1.30544},
>> {0.58, 1.31146},
>> {0.59, 1.31105},
>> {0.66, 1.32175},
>> {0.67, 1.32041},
>> {0.83, 1.81008},
>> {1.11, 0.0324386},
>> {1.71, 1.72145}}
>>
>> (Too many, if we assume the data is only approximate.)
>
> That approach works fine (at least with this data) if we widen the
> window and look more than one point to the left and right:
>
> With[{k = 2},
> data[[k + Flatten@Position[Partition[data[[All,2]],2k+1,1], x_List /;
> x[[k+1]] < Min[Delete[x,k+1]] || x[[k+1]] > Max[Delete[x,k+1]]]]]]
>
> will ignore the glitches and give
> {{0.83,1.81008},{1.11,0.0324386},{1.71,1.72145}}
>
>
>
>