I need to find the "Maxima" and "Minima" on a B-Spline or more correct the points where the 2nd components of the derivate equal zero.
For example:
g = BSplineFunction[{{1, 2}, {2, 4}, {3, -1}, {4, 2}}] ;
dg=g';
Solve[{dg[t][[2]] == 0, 0 <= t <= 1}, t]
The problem is that "Solve" wont work for this kind of application, and "Minimize" or similar functions stop at the first finding.
Any ideas?
CX
You can use MeshFunctions to do the trick:
g = BSplineFunction[{RandomReal[1, 20], RandomReal[1, 20]}\[Transpose]];
dg = g';
ParametricPlot[
g[t], {t, 0, 1},
MeshFunctions -> Function[{x, y, t}, dg[t].{0, 1}],
Mesh -> {{0}},
MeshStyle -> Directive[AbsolutePointSize[5], Red]
]
Here the MeshFunctions specifies the value of dg[t].{0, 1}, i.e. the $y$ component of the tangential vector of $g(t)$ at $t$, is used to generate mesh levels. Then Mesh -> {{0}} specifies that we only draw meshes where dg[t].{0, 1} == 0, which is exactly the extrema of $g(t)$.
To tell maxima from minima, use the RegionFunction:
maximapart = ParametricPlot[
g[t], {t, 0, 1},
PlotStyle -> Lighter[Blue, .6],
RegionFunction -> Function[{x, y, t}, g''[t].{0, 1} < 0],
MeshFunctions -> Function[{x, y, t}, dg[t].{0, 1}],
Mesh -> {{0}},
MeshStyle -> Directive[AbsolutePointSize[5], Red]
]
minimapart = ParametricPlot[
g[t], {t, 0, 1},
PlotStyle -> Lighter[Brown, .6],
RegionFunction -> Function[{x, y, t}, g''[t].{0, 1} > 0],
MeshFunctions -> Function[{x, y, t}, dg[t].{0, 1}],
Mesh -> {{0}},
MeshStyle -> Directive[AbsolutePointSize[5], Blue]
]
Show[{maximapart, minimapart}]
Extracting the points is straightforward:
maximaptSet = Cases[maximapart, GraphicsComplex[pt_, __] :> pt, ∞][[1]];
maximaIdx = Cases[maximapart, Point[pt_] :> pt, ∞][[1]];
maximaptSet[[maximaIdx]]
minimaptSet = Cases[minimapart, GraphicsComplex[pt_, __] :> pt, ∞][[1]];
minimaIdx = Cases[minimapart, Point[pt_] :> pt, ∞][[1]];
minimaptSet[[minimaIdx]]
dat = GaussianRandomField[nn = 32] // Chop; dat /= Max[dat]; dat *= nn/2; dat2 = Table[{i, j, dat[[i, j]]}, {i, nn}, {j, nn}]; bs = BSplineFunction[dat2]; dbs = Function[{u, v}, Sqrt[Derivative[1, 0][bs][u, v][[3]]^2 + Derivative[0, 1][bs][u, v][[3]]^2] // Evaluate]; ParametricPlot3D[bs[u, v], {u, 0, 1}, {v, 0, 1}, MeshFunctions -> Function[{x, y, z, u, v}, dbs[u, v]], MeshStyle -> Directive[AbsolutePointSize[Small], Red], Mesh -> {{0}}]
$\endgroup$
A more interesting example with multiple extrema..
g = BSplineFunction[{{1, 2}, {2, 4}, {3, -1}, {4, 2}, {5, 0}, {6, 1}}];
gp = g';
gpy[t_?NumericQ] := gp[t][[2]];
This is utilising Plot to generate the curve and look for zero crossings, which we then pass as starting points to FindRoot
loc = Flatten[
t /. # & /@
FindRoot[gpy[t] , Evaluate[ {t, Sequence @@ #[[;; , 1]]}]] & /@
Select[ Partition[
Cases[Plot[ gpy[t], {t, 0, 1}], Line[pts_] :> List[pts],
Infinity][[1, 1]] , 2, 1] , #[[1, 2]] #[[2, 2]] <= 0 & ] ]
Show[{ ParametricPlot[ g[t], {t, 0, 1}],
Graphics@{PointSize[.02], Point[g[#] & /@ loc]}} ]
now distinguish min/max by looking at the second derivative:
gpp = g'';
min = Select[ loc, gpp[#][[2]] > 0 &]
max = Select[ loc, gpp[#][[2]] < 0 &]
Show[{ ParametricPlot[ g[t], {t, 0, 1}],
Graphics@{Red, PointSize[.02], Point[g[#] & /@ min], Blue,
PointSize[.02], Point[g[#] & /@ max]}} ]
Table[gpy[t], {t, 0, 1,.01}] in place of the Cases[Plot..][[1,1]] because the function is nice enough we dont really need the adaptive sampling that comes from using Plot
$\endgroup$
Apr 21, 2014 at 17:45
How about
g = BSplineFunction[{{1, 2}, {2, 4}, {3, -1}, {4, 2}}];
gN[t_?NumericQ] := g[t][[2]]
So that gN[0.1] returns a number.
Then
NMinimize[{gN[t], t > 0, t < 1}, t]
NMaximize[{gN[t], t > 0, t < 1}, t]
(* {1.01494,{t->0.75726}} {2.48728,{t->0.176073}} *)
works.
NMinimize[{Abs@dgN[t], t > 0, t < 1}, t] but there exist two of them. And thats my problem. Minimize stops at the first finding
$\endgroup$
g instead of g' should do what you want (at least in this case with only one local min and max )
$\endgroup$
Apr 21, 2014 at 13:59