Minimum distance from P (0,0) to the curve

Which arrow corresponds to the minimum distance. I've this.

f[t_] := 1.5 + 0.95412 Exp[-(t/399.243)^0.500572] + 0.60082 Exp[-(t/601.739)^0.328243]

data = Table[{t, f[t]}, {t, 0, 18000}];

ListLinePlot[data,Ticks -> {Range[0, 18000, 2000], Range[0, 2, 0.05]},
Prolog -> {PointSize[0.02], Red, Point[{5000, 1.60858}]},
Epilog -> {Table[Arrow[{{0, 1.515}, {n, f[n]}}], {n, 3000, 8000, 500}]}]


This is my function to calculate de minimal distance bewteen two point, since 3000 to 8000, but the result is not correct. It give me around 3360.08 and by the graphic is 5000.

Min@Table[EuclideanDistance[{0, 1515}, {n, f[n]}], {n, 3000, 8000, 500}]
out:3360.08


The code of differences of slope is:

data = {{900, 1.903126}, {1800, 1.752655}, {2700, 1.7023}, {3600,1.64967}, {4500, 1.62171}, {5400, 1.59539}, {6300, 1.5773}, {7200,1.56414}, {8100, 1.56579}, {9000, 1.55592}, {9900, 1.55921}, {10800, 1.55263}, {11700, 1.5477}, {12600, 1.54441}, {13500, 1.54605}, {14400, 1.54276}, {15300,1.53783}, {16200, 1.53783}, {17100, 1.532461}, {18000, 1.525177}};

h[dx_, funcion_] := Module[{\[CapitalDelta]x = dx},
dif = Differences[
D[funcion, x] (x + \[CapitalDelta]x) - D[funcion, x] /.
x -> Range @@ {Min[#], Max[#]} &[First /@ data]];
valorx =
Flatten@Cases[
NSolve[D[funcion, x]*(x + \[CapitalDelta]x) - D[funcion, x] ==
Min@dif, x, Reals], {_ -> x_ /; x > 0}]; b = x /. valorx;
tangente[
a_] := (funcion /. x -> a) + (D[funcion, x] /. x -> a) (x - a);
Print[Style["RESUMEN", Black, Bold, 18]];
Print["El valor mín de la diferencia de pendiente es = ",
ScientificForm @@ Min@dif] ;
Print["Su ubicación es el punto: P" , {b*10^4,
funcion /. x -> b*10^4}  ];
Print["\n"];
graf1 =
Plot[funcion, {x, Min[#] &[First /@ data],
Max[#] &[First /@ data]}, AxesStyle -> Thick,
PlotLabel ->
Style["\!$$\*SuperscriptBox[\(\[Tau]$$, $$*$$]\) vs \
\!$$\*SuperscriptBox[\(P$$, $$*$$]\)" , 18, Black,
FontFamily -> "Kristen ITC"] ,
PlotStyle -> {Thickness[0.01], Blue},
ImageSize -> 400,
Epilog :> {  { Dashed, Thick,
Line[{{0, funcion /. x -> b*10^4}, {b*10^4,
funcion /. x -> b*10^4}, {b*10^4,
0}}]},(*linea discontinua*)
PointSize[0.02], Darker@Red,
Point[{b*10^4, funcion /. x -> b*10^4}],(*punto rojo*)
Arrow[{{(b*10^4) + 2050, (funcion /. x -> b*10^4) +
0.05}, {(b*10^4 + 300), (funcion /. x -> b*10^4) + 0.01}}],

Style[Text[{b*10^4,
funcion /. x -> b*10^4}, {(b*10^4) +
4900, (funcion /. x -> b*10^4) + 0.05}], Black, Bold, 12]}];
graf2 =
Plot[ Evaluate@tangente[b*10^4], {x, Min[#] &[First /@ data],
Max[#] &[First /@ data]}, PlotStyle -> {Thick, Black}];
graf3 =
Plot[ Evaluate@tangente[b*10^4 + \[CapitalDelta]x*1000], {x,
Min[#] &[First /@ data], Max[#] &[First /@ data]},
PlotStyle -> {Thick, Orange}];
Framed@Show[graf1, graf2, graf3]
]


My red point I get it from of this graphic.

• "and by the graphic is 5000" That's an incorrect subjective assessment. You chose the red point arbitrarily. The scale of the horizontal and vertical axes is very different./ – Szabolcs Jun 9 '18 at 13:56
• To add to what @Szabolcs said, there is also a typo: You wrote 1515 instead of 1.515 – Lukas Lang Jun 9 '18 at 15:31
• I am aware that the axes are very different, that is why the reason for my doubt. The red dot I get from my difference of slopes I show below in my code and I want to check with this method of arrows. – Andres Jun 9 '18 at 17:16
• The vector of the min distance is (in your graph) not orthogonal to the function. If one defines reg = ParametricRegion[{t, f[t]}, {{t, 0, 18000}}] one gets a minimal distance of RegionDistance[reg, {0, 1.515}] value: 1.49, maybe I misunderstood something – mgamer Jun 9 '18 at 22:02

Your approach seems more complicated than needed, but I wonder if I misunderstand your goal. Anyway, the following will find the point on the curve that is closest to the origin $(0,0)$:

minimum = NMinimize[EuclideanDistance[{0, 0}, {x, f[x]}], x]

(* Out: {2.9967, {x -> 0.284259}} *)


Graphically:

{mindist = #1, xmin = x /. #2} & @@ minimum;

Plot[
Style[f[t], Thick, Black], {t, 0, 2},
PlotRange -> {Automatic, {0, 3.1}}, AspectRatio -> Automatic,
LabelStyle -> Directive[Black, Medium],
Epilog -> {
Red, PointSize[0.03], Point[{xmin, f[xmin]}],
Table[
Style[Arrow[{{0, 0}, {n, f[n]}}], Blend[{Red, Black}, Abs[(n - xmin)/xmin]^0.7]],
{n, Range[0, 0.56, 0.07] ~ Join ~ {0.64, 0.74, 0.9, 1.1, 1.33, 1.6, 1.9}}
]
}
]


Alternatively you can look at a plot of the distance itself:

Plot[
EuclideanDistance[{0, 0}, {x, f[x]}], {x, 0, 1},
Frame -> {{True, False}, {True, False}}, Axes -> False,

• Manipulate[ ListLinePlot[data,Ticks -> {Range[0, 18000, 2000], Range[0, 2, 0.05]}, Prolog -> {Text[Style["Distance = ?", 14, Bold], {10000, 1.8}]}, Epilog -> {Arrow[{{0, 1.515}, {n, f[n]}}]}],Row[{Control[{{n, 2000, "Values (Axes X)"}, 2000, 9000, 100}], " ", Dynamic[n]}]] – Andres Jun 12 '18 at 4:09