4
$\begingroup$

I want to find the coordinates of the tangent point between a convex curve and a line that passes from a point with known coordinates (0,b) ("efficient portfolio" in finance). My problem is that the curve formula ("efficient frontier") is not known, hence it can only be inferred from a set of pre-calculated points. Important points.

1) I am only interested in the upper part of the curve starting from the left-most point. 2) The tangent point is unique. 3) Quadratic Fit did not work (please see below) since it failed at the more convex part on the left (the curve may appear flat).

The output should ideally be a set of coordinates (x,y) or a set of rules.

I provide a dataset for the curve in a DropBox link here...

...a plot of the quadratic Fit curve in blue together with the plotted data in red ("efficient frontier") and a general drawing of the solution.

bill = Fit[data, {1, x, x^2}, x]
Show[ListLinePlot[data, PlotRange -> {{0, 0.1}, {0, 0.05}}, 
PlotStyle -> Red], Plot[bill, {x, 0, 0.1}]]  

enter image description here enter image description here

I know there are many similar topics, but all the ones I found refer to tangents where the equation is known. I include a toy code that produces a solution based on MarcoB's answer here for b=2 but I don't know how meaningful it is since the curve function is known.

y[x_] := a x + 2                     
f[x_] := 3 x^2 - 2 x + 5
sol = List@ToRules@Reduce[{y[x1] == f[x1], y'[x1] == f'[x1]}, {x1}]
Plot[{f[x], y[x] /. sol}, {x, -2, 2}, 
Epilog -> {PointSize[0.015], Point[{x1, f[x1]}] //. sol}]

{{a -> -8, x1 -> (2 + a)/6}, {a -> 4, x1 -> (2 + a)/6}}

$\endgroup$
5
$\begingroup$

Assuming the curve is convex and $(0, b)$ is "outside" the curve, you can use the convex hull of the point and data.

b = -0.01;
bp = {0., b};
c = ConvexHullMesh[Join[{bp}, data]]["Coordinates"];
p = Position[c, bp][[1, 1]];
l = Cases[MeshCells[ConvexHullMesh[Join[{bp}, data]], 1], (* lines containing bp *)
   Line[i : {___, p, ___}] :> i];
m = First@Ratios@First@Differences@c[[#]] & /@ l;   (* slopes of those lines *)
(* tp = line segment with greatest slope containing the point bp *)
tp = InfiniteLine[ c[[ l~Part~Last@Ordering[m] ]] ]
(*  InfiniteLine[{{0.0270945, 0.0108}, {0., -0.01}}]  *)

Show[
 ListLinePlot[data, PlotRange -> {{0, 0.1}, {0, 0.05}}, PlotStyle -> Red],
 Graphics[{Point[bp], tp}],
 PlotRange -> All
 ]

enter image description here

$\endgroup$
  • $\begingroup$ Excellent! Thank you very much for your help, this does exactly what I wanted. I could never code something like that since I am not familiar with mesh functions. Many thanks again! $\endgroup$ – Titus Jun 5 at 20:44
5
$\begingroup$
ClearAll[slope, opt]
slope[rf_] := Divide @@ Reverse[rf - #] &;
opt[dt_, rf_] := dt[[First @ Ordering[slope[rf] /@ dt, -1]]];

rfp = {0., -.01};
opt[data, rfp]

{0.0270945, 0.0108}

Row[Show[ListLinePlot[data, 
     Epilog -> {Red, PointSize[Large], Point[{rfp, opt[data, rfp]}] }, 
     ImageSize -> Medium], 
    Plot[rf[[-1]] + x slope [rf][opt[data, rfp]] , {x, 0, 0.2}, 
     PlotStyle -> Green], 
    PlotRange -> #] & /@ {{-0.02, .07}, {{0, .07}, {-0.02, .03}}}, 
 Spacer[10]]

enter image description here

You could also use the simpler but slower:

opt[dt_, rf_] := Last @ SortBy[dt, slope[rf]];
$\endgroup$
  • $\begingroup$ Thank you very much! This is very interesting because it does not use the curve but maximises the slope for a given dataset, which is also valid. I understand how opt is built, but could you explain slope? $\endgroup$ – Titus Jun 6 at 8:08
  • 1
    $\begingroup$ @Titus, slope takes a reference point (rf ={x0,y0}) and for any point {x1,y1} to find the ratio of vertical displacement (y1-y0) to horizontal displacement (x1-x0) it (1) finds the difference {x0,y0} - {x1,y1} (which is, {x0-x1, y0 - y1}), (2) Reverses the result (to get {y0-y1, x0-x1}), then (3) Divides the result to get (y0 - y1)/(x0-x1). $\endgroup$ – kglr Jun 6 at 8:18
1
$\begingroup$

Sorry I'm a little bit late.

Perhaps this approach finds your interest. I try to calculate the minimal cone(peak at {0,0} ) including all points!

a = {a1, a2};(* centre line of cones *)
opt = NMinimize[{ Max[Map[Abs@ArcCos[ a.(#/Sqrt[#.#])]  &, data]] ,a.a == 1 }, a];  
ak = a /. opt[[2]]; (* optimal cone axis*)
dk = opt[[1]]  (* optimal cone angle*)

Show[{ListPlot[data],Graphics[{Opacity[.2], Red, 
Polygon[2 {{0, 0}, RotationMatrix[dk]. ak, RotationMatrix[-dk]. ak, {0, 0}}], Line[1.3 { {0, 0}, ak}] }]}, PlotRange -> {{{0, 1}, {0, 1}}, All, {{0, .2}, {0, .1}}}[[-1]],AxesOrigin -> {0, 0}, AspectRatio -> 1]

enter image description here

The minimization can easily be extended to higher order dimensions.

$\endgroup$

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.