Find the best parallel lines to a given data set

Question

I have a set of data in an uptrend. I would like to find two BEST parallel lines to contain all the data but I don't know how to approach it, anyone can help ? Thanks.

Answer 1

This is a computational geometry problem. I'll illustrate a solution using some sample data:

Needs["ComputationalGeometry`"]
pts = Table[{x, Sin[x*3] + x/2. + RandomReal[.5]}, {x, 0, 10, .1}];
ListPlot[pts]

You want to find 3 "support points" in your data, that touch these two lines. Now imagine you had a "convex hull", i.e. the smallest convex polygon that contains all your data points. Calculating a convex hull is cheap (at least in 2D) and it eliminates most of the points in your data:

hull = ConvexHull[pts];

ListPlot[pts, 
 Epilog -> {Red, Point[pts[[hull]]], Opacity[0.2], 
   Line[pts[[Append[hull, hull[[1]]]]]]}]

Obviously, the support points you're looking for are all on the convex hull. And two of them are next to each other on the convex hull.

EDIT: I'll shamelessly copy @Kuba's idea to minimize m first, as it makes the solution so much simpler:

(* find the possible value for m - the slopes between each adjacent \
pair of points on the convex hull *)
possibleMs = 
  Divide @@@ Differences[Reverse /@ pts[[Append[hull, hull[[1]]]]]];
(* find the m with the smallest c2-c1 difference *)
m = SortBy[possibleMs, Max[#] - Min[#] &[pts[[hull]].{-#, 1}] &][[1]];
(* find c1 and c2 *)
{c1, c2} = {Max[#], Min[#]} &[pts[[hull]].{-m, 1}];

ListPlot[pts, 
 Epilog -> {Red, Dashed, Line[{{0, c1}, {10, 10 m + c1}}], 
   Line[{{0, c2}, {10, 10 m + c2}}]}]

Answer 2

Solution with NMinimize:

data = Table[Sin[15 x] + 3 x + RandomReal[] + 5, {x, 0, 1, .005}];

ListPlot[data, AxesOrigin -> {0, 0}]

The basic idea is to reduce the data so that lines we are looking for are going to be parallel to OX axis with (data - m ran). Then Max-Min value of such data set is the exactly equal to |c1-c2|.

ran = Range[1, Length@data];
ClearAll[m];
sol = NMinimize[Max[#] - Min[#] &[data - (m ran)], m]

{2.86863, {m -> 0.0152302}}

{a, c1, c2} = {m, Max[#], Min[#]} &[data - (m ran)] /. sol[[ 2]]

{0.0152302, 6.84349, 3.97486}

Plot[{a x + c1, a x + c2}, {x, 0, 200}, Epilog -> Point[Transpose[{ran, data}]]]

---

Just another data set:

data = Table[Sin[x/10]/(x/200) + x/50 + RandomReal[] + 5, {x, 50, 200}];
(*calculations*)

Answer 3

An easy, no brain used, direct approach:

pts = Table[{x, Sin[x*3] + x/2. + RandomReal[.5]}, {x, 0,  10, .1}]; 
sol = Minimize[{c2 - c1, 
                And @@ (m #[[1]] + c1 <= #[[2]] <= (m #[[1]] + c2) & /@ pts)}, 
                {c1, c2, m}]


Show[Plot[{(m x + c1), (m x + c2)} /. sol[[2]], {x, 0, 10}], ListPlot[pts]]

With the other Kuba's example:

pts = Table[{x, Sin[x/10]/(x/200) + x/50 + RandomReal[] + 5}, {x, 50,  200}];

Edit

If you want to minimize the distance between the two lines, the results are slightly different:

pts = Table[{x, Sin[x/10]/(x/200) + x/50 + RandomReal[] + 5}, {x, 50, 200}];
sol = Quiet@ NMinimize[{Abs[(c2 - c1)] Cos[ArcTan[m]], 
                       m > 0 && 
                       FullSimplify[ And @@ (m #[[1]] + c1 <= #[[2]] <= (m #[[1]] + c2) & /@ pts)]}, 
                       {c1, c2, m}]
Show[Plot[{(m x + c1), (m x + c2)} /. sol[[2]], {x, 0, 200}], ListPlot[pts]]