Re: Filtering data from numerical minimization
- To: mathgroup at smc.vnet.net
- Subject: [mg116813] Re: Filtering data from numerical minimization
- From: Ray Koopman <koopman at sfu.ca>
- Date: Tue, 1 Mar 2011 05:22:03 -0500 (EST)
- References: <ijasgs$ned$1@smc.vnet.net> <ikfv4k$f7v$1@smc.vnet.net>
On Feb 28, 2:58 am, Sebastian <sebho... at gmail.com> wrote:
> On Feb 14, 10:26 am, Ray Koopman <koop... at sfu.ca> wrote:
>
>> Try increasing WorkingPrecision, AccuracyGoal, and PrecisionGoal.
>> Also, try a different Method. If that doesn't fix things, try using
>> better starting intervals. This may take two passes thru the list
>> 1...N. On the first pass, use your best a priori guess. On the
>> second pass, take the results from n-1 and n+1 on the previous pass
>> as the starting intervals for n. Take whichever results (pass 1 or
>> 2) give a lower fmin. Iterate (pass 3,4,...) until it stabilizes.
>
> The minimization is actually done in a similar way, as I use the
> optimal values from n-1 to generate initial values and constraints
> for n. It is funny that although I have these outliers, NMinimize
> finds its way back to a "good" value for the following points.
> Anyway... in the end I tackled my problem by defining a function
> which drops all points which violate monotonicity and applied it to
> my data by using FixedPoint. This may not be a general solution, but
> it worked reasonably well for this specific case. In case someone
> has a similar problem in the future, I included my code below.
>
> Cheers and thanks again for your help!
> Sebastian
>
> DefineFilter[cond_,options:OptionsPattern[]]:=
> Module[{ret},
> ret=Switch[OptionValue[ReturnValue],"Position",True,_,False];
> Return@With[{ret=ret},Function[t,
> Select[Table[If[i==1||i==Length@t||cond[t,i],If[ret,i,t[[i]]]],
> {i,1,Length@t}],#=!=Null&]]];
> ];
> Options[DefineFilter]={ReturnValue->"Value"};
> Attributes[DefineFilter]={HoldAll};
>
> (*usage example: only keep points which lie between
> the previous and following value*)
> filter=DefineFilter[(f /. #1[[#2 - 1]]) < (f /. #1[[#2]]) < (f /.
> #1[[#2 + 1]]) &];
> datf=FixedPoint[cfilter, dat];
I can't get your code to run. Here is a function
that I think does what yours is supposed to do:
filter[data_] := FixedPoint[Flatten@Join[{#[[1]]},
If[OrderedQ@#,#[[2]],{}]&/@Partition[#,3,1], {#[[-1]]}]&, data]
I know you said that the errors in your data are deterministic,
not random, but nevertheless consider the following:
data = Range[n = 30] + RandomReal[NormalDistribution[0,.75],n]
{0.92655, 1.30388, 3.03193, 5.80771, 4.66381, 5.76605, 6.96496,
7.69883, 9.1255, 9.26462, 11.0126, 12.0445, 14.4794, 15.7246,
15.9259, 14.9641, 17.0921, 17.1325, 19.0079, 19.4272, 19.8135,
22.3691, 24.1007, 24.611, 24.0087, 26.3429, 26.0191, 28.155,
30.1278, 29.3931}
ListPlot[data] shows some minor local nomonotonocity.
filter[data]
OrderedQ@%
{0.92655, 1.30388, 3.03193, 5.76605, 6.96496, 7.69883, 9.1255,
9.26462, 11.0126, 12.0445, 14.4794, 15.7246, 17.0921, 17.1325,
19.0079, 19.4272, 19.8135, 22.3691, 24.1007, 28.155, 29.3931}
True
So far, so good. But consider the following routine,
that looks for the minimal set of points to drop,
up to some maximum number, to get a monotone sequence:
dropper[data_,max_] := If[OrderedQ@data,{{}},
Block[{n = 0, s}, While[++n <= max &&
(s = Select[Subsets[Range@Length@data,{n}],
OrderedQ@Delete[data,Transpose@{#}]&]) == {}]; s]]
dropper[data,5]
{{4, 16, 25, 26, 29}, {4, 16, 25, 26, 30},
{4, 16, 25, 27, 29}, {4, 16, 25, 27, 30}}
Your filter dropped 9 points, but there are 4 different
ways to get a monotone sequence by dropping only 5 points.
You haven't said how long your data vectors are, so I don't know
whether the brute force method used in dropper would be feasible
for your data. In any case, you should realize that your filter
could be deleting points that should be kept.