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.

find parallel lines

  • 2
    $\begingroup$ Please provide the data to work on. Is this homework? $\endgroup$
    – Kuba
    Dec 16, 2013 at 8:37
  • $\begingroup$ Hi, yes, it is a programming problem from college project. i just randomly pick some data to show what my problem is. $\endgroup$
    – user11169
    Dec 16, 2013 at 9:07
  • 2
    $\begingroup$ I'm not sure what is the policy about homeworks but this might be usefull so I suspect it will not be deleted. However it is also good to provide the data set, even randomly generated, it will focus more attention. Moreover it may be important, here for example we do not know if we have to work on list of values or list of points. $\endgroup$
    – Kuba
    Dec 16, 2013 at 9:15
  • $\begingroup$ Thanks for your suggestion. The problem is not directly related to college project, but I come up with something and wanted to prove it using programming but I stuck here. Yes, I can share the data but it is my a newbie here so I don't know how to upload my sample data. $\endgroup$
    – user11169
    Dec 16, 2013 at 9:28
  • 2
    $\begingroup$ You don't have to because it is about Mathematica :) $\endgroup$
    – Kuba
    Dec 16, 2013 at 9:31

3 Answers 3


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

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

enter image description here

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

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

enter image description here

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

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

enter image description here


Solution with NMinimize:

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

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

enter image description here

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

enter image description here

Just another data set:

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

enter image description here


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

Mathematica graphics

With the other Kuba's example:

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

Mathematica graphics


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

Mathematica graphics


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.