1
$\begingroup$

I have to find 25 points that lie nearest to a linear approximation of my data.

This is my source code:

xx = {250, 185, 265, 292, 258, 249, 233, 321, 314, 228, 214, 306, 320,
338, 345, 350, 349, 294, 284, 266, 244, 225, 205, 209, 202, 211, 
218, 214, 201, 194, 186, 182, 194, 195, 190, 185, 180, 177, 173, 
170, 173, 185, 190, 181, 181, 171, 174, 172, 172, 172, 174, 181, 
174, 169, 167, 166, 165, 162, 159, 156, 153, 168, 174, 176, 177, 
182, 184, 181, 182, 181, 180, 182, 215, 218, 238, 239, 242, 237, 
231, 212, 208, 193, 198, 187, 192, 191, 187, 178, 176, 176, 184, 
189, 180, 220, 218, 214, 206, 180, 178, 196, 214, 222, 233, 248, 
254, 262, 274, 281, 279, 292, 292, 290, 210, 213, 207, 194, 203, 
200, 186, 178, 170, 166, 162, 150, 164, 196, 208, 212, 208, 206, 
208, 203, 200, 200, 203, 198, 194, 194, 192, 188, 174, 177, 182, 
224, 210, 208, 202, 222, 218, 216, 222, 246, 286, 298, 308, 310, 
311, 325, 301, 292, 284, 258, 216, 212, 224, 216, 220, 225, 227, 
228, 229, 230, 243, 259, 262, 265, 266, 274, 270, 264, 258, 252, 
252, 241, 238, 226, 211, 214, 237, 244, 244, 237, 222, 210, 218, 
224, 225, 218, 230, 228, 208, 200, 196, 200, 206, 208, 214, 203, 
204, 203, 194, 188, 184, 180, 174, 214, 210, 196, 192, 191, 192, 
194, 186, 188, 194, 186, 186, 184, 188, 197, 190, 208, 218};
yy = {9.45, 3.48, 13.3, 16.5, 12.1, 10.2, 9.08, 26.2, 23.7, 7.4, 4.74,
20.04, 26.1, 29.9, 29.9, 29.9, 29.1, 14.8, 15.6, 13.4, 9.4, 6.8, 
3.47, 6.76, 6, 5.81, 7.06, 6.09, 7.16, 5.97, 4.96, 4.08, 5.98, 4.5,
4.54, 3.82, 3.07, 2.06, 2.19, 2.84, 2.45, 3.81, 3.44, 3.25, 3.42, 
2.71, 2.41, 2.49, 4.4, 3.66, 2.78, 5.08, 3.16, 3.66, 4.57, 2.48, 
2.14, 1.69, 1.46, 1.21, 1.1, 2.96, 0.991, 2.57, 1.73, 2.17, 1.76, 
2.5, 1.33, 1.44, 1.39, 3.16, 6.75, 7.06, 9.06, 10.2, 10.3, 9.82, 
8.79, 4.87, 5.66, 4.58, 3.84, 2.04, 1.65, 1.38, 1.35, 1.5, 1.07, 
2.42, 2.6, 2.14, 2.09, 8.88, 5.83, 5.52, 4.69, 1.59, 1.45, 2.9, 
4.56, 5.88, 7.4, 9.33, 11.5, 12.6, 13.9, 15.4, 15.7, 15, 18.6, 
17.9, 5.32, 5.72, 2.71, 5.29, 6.76, 4.8, 3.49, 2.88, 1.85, 1.63, 
1.54, 0.903, 1.46, 5.37, 4.76, 7.33, 5.24, 6.9, 6.73, 6.4, 5.33, 
6.14, 6.2, 5.17, 4.71, 4.67, 4.23, 4.37, 2.06, 3.09, 3.79, 5.04, 
4.86, 5.21, 4.78, 5.52, 5.76, 6.34, 6.75, 12.6, 17.2, 19.6, 16.5, 
18.3, 20.7, 19, 18.1, 17.9, 9.75, 8.1, 3.61, 3.58, 12, 5.52, 5.28, 
8.68, 8.56, 7.42, 9.83, 9.59, 14.9, 16, 14.3, 13.2, 13.7, 16.7, 
14.9, 12.5, 11.9, 12, 11.9, 10.6, 8.09, 8.4, 6.39, 5.98, 12.3, 
11.1, 8.77, 10.9, 7.2, 7.56, 8.78, 9.18, 8.11, 8.5, 10.1, 9.32, 
5.35, 5.22, 5.28, 5.34, 5.84, 6.88, 6.78, 5.16, 5.32, 5.06, 4.65, 
3.94, 3.87, 3.2, 3.08, 5.48, 4.87, 4.81, 4.85, 4.5, 4.07, 4.37, 
3.65, 3.95, 4.33, 4.14, 3.95, 3.8, 3.91, 4.07, 4.1, 7.01, 7.61};
ListPlot[Table[{yy[[n]], xx[[n]]}, {n, Length[xx]}]]

How can I do it? Please for help. I am beginner programmer and I can't do it.

$\endgroup$
  • $\begingroup$ correct Length[xx] $\endgroup$ – J42161217 May 13 '17 at 0:14
  • $\begingroup$ indeed xx, earlier I had x. My bad $\endgroup$ – criser May 13 '17 at 0:16
  • $\begingroup$ A tip for you — there is a much simpler way to plot your data: ListPlot[Transpose[{xx, yy}]] $\endgroup$ – m_goldberg May 13 '17 at 7:54
  • $\begingroup$ Are the 25 points supposed to be points in your data Table[{yy[[n]], xx[[n]]}, {n, Length[xx]}] or just any 25 points? And are they supposed to be closest to the best fit line? The currently accepted answer does none of these. $\endgroup$ – Michael E2 May 14 '17 at 14:57
  • $\begingroup$ Do you mean "nearest" in the normal sense of best fit, that is, least residual? $\endgroup$ – Michael E2 May 14 '17 at 15:00
1
$\begingroup$

here you are
this is your data

enter image description here

add this lines under your code

S = {};
For[i = 1, i <= 25, i++, 
AppendTo[S, Nearest[Riffle[xx, yy], {i, 8*i + 155}]]];
S = Partition[Max /@ Flatten[S, 1], 2]
ListPlot[S]

these are the 25 points

{{0.991, 164}, {2.04, 171}, {2.96, 180}, {3.95, 187}, {5.04, 195}, {6, 203}, {7.01, 211}, {8.09, 220}, {9.06, 227}, {10.1, 237}, {11.1, 243}, {12, 252}, {13.2, 259}, {13.9, 266}, {15, 274}, {16, 284}, {17.2, 292}, {18.1, 298}, {19, 308}, {20.04, 314}, {20.7, 325}, {20.7, 325}, {23.7, 338}, {23.7, 349}, {26.1, 350}}

and this is the graph

enter image description here

|improve this answer|||||
$\endgroup$
  • $\begingroup$ For and AppendTo are bad practice. You should replace the first three lines with S = Table[...]. $\endgroup$ – Michael E2 May 14 '17 at 14:41
4
$\begingroup$

Since the OP mentions linear approximation, I would measure "nearest" by the appropriate error, that is, the residual. It seems quite inappropriate to use the (Euclidean) distance between points, even though the second set of points $(x, f(x))$ correspond to the data points $(x, y)$, where $f$ gives the best-fit line. It is quite possible for the nearest point to $(x_1, y_1)$ to be $(x_2, f(x_2))$ for an $x_2 \ne x_1$ and not $(x_1, f(x_1))$. Unless you can show that such a thing cannot happen for the given data and calculated line, then you risk getting the wrong answer for a linear approximation problem. And even if you can show it, it seems a roundabout method to use, since it will raise questions for anybody reading the solution.

pp = Transpose@{yy, xx};               (* data *)
lmf = LinearModelFit[pp, {1, y}, y];   (* get linear approximation *)
indices = Take[Ordering@Abs@lmf["FitResiduals"], 25]; (* take least 25 positions *)
least25 = Sort@pp[[indices]]           (* get corresponding points *)
(* lmf /@ least25[[All, 1]] - least25[[All, 2]] (* optional: check residuals *)*)
(*
  {{0.991, 174}, {1.5, 178},  {1.73, 177}, {2.09, 180}, {2.17, 182}, {2.6, 184},
   {3.44, 190},  {4.07, 192}, {4.33, 194}, {4.37, 194}, {4.5, 195},  {4.8, 200},
   {5.16, 203},  {5.22, 200}, {5.32, 204}, {5.84, 206}, {6.39, 211}, {6.78, 214},
   {7.61, 218},  {8.68, 225}, {9.32, 228}, {9.59, 230}, {14.9, 270}, {17.9, 290},
   {18.6, 292}}
*)

With[{plot = Plot[lmf[y], {y, Min@pp[[All, 1]], Max@pp[[All, 1]]}]},
 Show[
  Graphics@ Point@pp,
  plot,
  Graphics@ {Red, PointSize[Medium], Point@least25},
  Frame -> True, Axes -> False, PlotRange -> All, 
  PlotRangePadding -> Scaled[0.05],
  Options@plot]
 ]

Mathematica graphics

|improve this answer|||||
$\endgroup$
3
$\begingroup$

Fitting the data,

data = Transpose[{yy, xx}];
line[x_] = Fit[data , {1, x}, x]

Generate a line using extreme points of the data, then compute distance between the points and the line, and finally sort the data.

a = Line@({#, line[#]} & /@ MinMax[yy])
b = SortBy[{#, RegionDistance[a, #]} & /@ data, Last]

b[[1;;25,1]] gives the first nearest points to the linear fit

{{7.61, 218}, {5.84, 206}, {2.09, 180}, {2.6, 184}, {8.68, 225}, {3.44, 190}, {1.73, 177}, {4.8, 200}, {17.9, 290}, {2.17, 182}, {6.39, 211}, {0.991, 174}, {18.6, 292}, {4.33, 194}, {5.22, 200}, {9.59, 230}, {6.78, 214}, {5.32, 204}, {4.5, 195}, {4.07, 192}, {5.16, 203}, {9.32, 228}, {4.37, 194}, {14.9, 270}, {1.5, 178}}

|improve this answer|||||
$\endgroup$
2
$\begingroup$
pts = Transpose[{xx, yy}];
f = LinearModelFit[pts, {x}, x];
linepts = Thread[{#, Function[x, f[x], Listable][#]}] &@(Range @@ MinMax[xx]);
distmat = DistanceMatrix[pts, linepts];
distance = MinimalBy[distmat~Flatten~1, EuclideanDistance[#, {0, 0}] &, 25];
selections = Extract[pts,
Position[distmat, Alternatives @@ distance][[All, 1]]~Partition~1];

Show[ListPlot[selections, PlotStyle -> Black], ListPlot[linepts, Joined -> True]]

enter image description here

|improve this answer|||||
$\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.