1
$\begingroup$

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}]}]

enter image description here

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*)  
                          Darker@Green, Arrowheads[0.03], 
      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.

enter image description here

$\endgroup$
  • 2
    $\begingroup$ "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./ $\endgroup$ – Szabolcs Jun 9 '18 at 13:56
  • 1
    $\begingroup$ To add to what @Szabolcs said, there is also a typo: You wrote 1515 instead of 1.515 $\endgroup$ – Lukas Lang Jun 9 '18 at 15:31
  • $\begingroup$ 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. $\endgroup$ – Andres Jun 9 '18 at 17:16
  • $\begingroup$ 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 $\endgroup$ – mgamer Jun 9 '18 at 22:02
2
$\begingroup$

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]}],
    Arrowheads[0.05],
    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}}
    ]
  }
]

arrow plot

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,
  PlotRangePadding -> Thread[Scaled[{0, 0.1}]],
  Epilog -> {
    Red, InfiniteLine[{{0, mindist}, {3, mindist}}],
    PointSize[0.02], Point[{xmin, mindist}]
  }
]

distance plot

|improve this answer|||||
$\endgroup$
  • $\begingroup$ It is not about the point that is closest to the origin. My goal is to find the arrow that represent the minimal distance to experimental curve. According to my program this point is in the (4999.75,1.60859). See the graphic previous. $\endgroup$ – Andres Jun 10 '18 at 14:42
  • $\begingroup$ @Andres Could you explain exactly what kind of distance you are looking for then? $\endgroup$ – MarcoB Jun 11 '18 at 22:22
  • $\begingroup$ Knowing how to calculate this distance, can modify the code to find the minimum distance. This example may help. $\endgroup$ – Andres Jun 12 '18 at 4:07
  • $\begingroup$ 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]}]] $\endgroup$ – Andres Jun 12 '18 at 4:09
  • $\begingroup$ In each positon, the arrow have a distance from the origin to the curve and, according to the previous graph of the arrows, it is observed that only one of them represents the shortest distance from the origin to the curve. The goal is to find this minimum distance. $\endgroup$ – Andres Jun 12 '18 at 4:19

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.