Minimization in single component of BSpline to extract points

Question

I smoothed some data with a BSpline $B[t] = (x[t],y[t])$. I would like to extract certain points from this spline by their x-Values, $x_0$. The easiest way I came up with was to minimize $B[t][[1]]-x_0$ for $t \in [0,1]$. So for finding the parameter t at which the x value is 13.46 if have the following code:

data = {{9.93114`, 379022.8`}, {11.71875`, 321705.7`}, {13.46983`, 
280830.8`}, {15.625`, 243949.8`}, {18.60119`, 206915}, {21.70139`,
 179663.2`}, {24.93351`, 158942.4`}, {29.29688`, 
138396.2`}, {33.48214`, 123873.8`}};

spline = BSplineFunction[data, SplineDegree -> 3];
tstfc[t_] := spline[t][[1]]

FindMinimum[Abs[tstfc[x] - 13.46] , {x, 0}]

It seems like the Spline is not getting evaluated. How can I solve this? And is there a standard way to extract points from a spline? Thanks!

Answer 1

data = {{9.93114`, 379022.8`}, {11.71875`, 321705.7`}, {13.46983`, 
280830.8`}, {15.625`, 243949.8`}, {18.60119`, 206915}, {21.70139`, 
179663.2`}, {24.93351`, 158942.4`}, {29.29688`, 138396.2`}, {33.48214`, 
123873.8`}};

spline = BSplineFunction[data, SplineDegree -> 3];

Clear[tstfc];

You need to restrict the definition of tstfc to numeric arguments. Using the symbolic result causes your problem.

tstfc[t_?NumericQ] := spline[t][[1]]

The function being minimized clearly has a local minimum:

Plot[Abs[tstfc[x] - 13.46], {x, 0, 1}]

Plot[Abs[tstfc[x] - 13.46], {x, 0.17, .173}]

You should also constrain x.Even so, FindMinimum has some difficulty.

FindMinimum[{Abs[tstfc[x] - 13.46], 0 <= x <= 1}, {x, .2}]

FindMinimum::eit: The algorithm does not converge to the tolerance of 4.806217383937354`*^-6 in 500 iterations. The best estimated solution, with feasibility residual, KKT residual, or complementary residual of {2.00154,0.757541,1.00077}, is returned. >>

{0.000010463696439089176, {x -> 0.17147137220615655}}

NMinimize works better.

NMinimize[{Abs[tstfc[x] - 13.46], 0 <= x <= 1}, x]

{1.0658141036401503*^-13, {x -> 0.17147210562361115}}

Answer 2

If your aim is to find the parameter value t that maps to {13.46, _} in the B spline you could use:

data = {{9.93114`, 379022.8`}, {11.71875`, 321705.7`}, {13.46983`, 
    280830.8`}, {15.625`, 243949.8`}, {18.60119`, 206915}, {21.70139`,
     179663.2`}, {24.93351`, 158942.4`}, {29.29688`, 
    138396.2`}, {33.48214`, 123873.8`}};
bf = BSplineFunction[data, SplineDegree -> 3];
d = Table[{bf[t][[1]], t}, {t, 0, 1, 0.01}];
ifn = Interpolation[d];

Then

ans = ifn[13.46]

yields:

0.171472

and the point on spline:

bf[ans]

{13.46, 283497.}

You could adjust to desired precision.

Answer 3

The documentation says in its very first sentence:

FindMinimum[f, x] searches for a local minimum in f, starting from an automatically selected point.

Not ANY minimum but a LOCAL minimum.

Google it with http://en.wikipedia.org/wiki/Maxima_and_minima

As already stated yesterday, your data doesn't contain LOCAL minima and/or maxima. Your data has one GLOBAL maximum and one GLOBAL minimum which, thanks Mathematica, can be found as follows:

{First@data, Last@data}

Aside from this, your "getPointNewton" simply doesn't work. If it works with you, could you provide an example?

Answer 4

A workaround is a Newton algorithm, if the spline is used with a Modulo 1 parameter, modelling a periodic spline function. The function to be minimized is then spline[t_] := Abs[spline[t][[1]] - x0];

getPointNewton[x0_, splinein_, tstart_] := 
 Module[{d, t, dert, dt, spline},
  spline[t_] := Abs[spline[t][[1]] - x0];
  t = tstart;
  dt = 0.001;
  d = 1;
  While[d > 0.00000005,
   dert = (spline[t + dt] - spline[t - dt])/(2 dt);
   t = Mod[t - spline[t]/dert, 1];
  d = Abs[splinein[t][[1]] - x0];
   ];
  t
  ]

Edit: Works fine for this dataset, gives 0.171472 after 345 iterations, but has problems converging in more extreme data (higher derivatives/values) and close to boundaries.

The standard minimization routines in Mathematica seem to take a lot of time for convergence.

A better algorithm, which converges on the wished parameter from the left only is this one:

getPointLeft[x0_, spline_, tstart_] := 
 Module[{i, t, basestep, points}, i = 0;
  t = tstart;
 basestep = 1;
  points = {0};
  While[Abs[spline[t][[1]] - x0] > 0.000005, 
  If[spline[t + (1/2)^i basestep][[1]] > x0, i++, 
    t = t + (1/2)^i basestep;
    AppendTo[points, N[t]]]];
  points]

data = {{9.93114`, 379022.8`}, {11.71875`, 321705.7`}, {13.46983`, 
    280830.8`}, {15.625`, 243949.8`}, {18.60119`, 206915}, {21.70139`,
     179663.2`}, {24.93351`, 158942.4`}, {29.29688`, 
    138396.2`}, {33.48214`, 123873.8`}};

spline = BSplineFunction[data, SplineDegree -> 3];
points = getPointLeft[13.46, spline, 0]
Show[Plot[Abs[spline[t][[1]] - 13.46], {t, 0, 0.2}], 
 Graphics[{PointSize[Large], Red, 
   Point[Transpose[{points, 
      Abs[spline[#][[1]] - 13.46] & /@ points}]]}]]

It halfs the stepsize as long as the next step would overshoot. This works well to find the next local minimum, which is fine for a case in which the dependent variable looked for is a monotonous function of the parameter t. Result:0.171472 after 33 iterations.