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