Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

share|improve this question
2  
Please provide the data to work on. Is this homework? –  Kuba Dec 16 '13 at 8:37
    
Hi, yes, it is a programming problem from college project. i just randomly pick some data to show what my problem is. –  user11169 Dec 16 '13 at 9:07
2  
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. –  Kuba Dec 16 '13 at 9:15
    
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. –  user11169 Dec 16 '13 at 9:28
2  
You don't have to because it is about Mathematica :) –  Kuba Dec 16 '13 at 9:31

3 Answers 3

up vote 7 down vote accepted

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]

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

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

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

enter image description here

share|improve this answer

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

enter image description here


Just another data set:

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

enter image description here

share|improve this answer

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

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

Mathematica graphics

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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