3
$\begingroup$

Here are my data points:

{{86.0365, 38.6844}, {86.0526, 38.6998}, {86.069, 38.7154}, {86.085, 
  38.7308}, {86.1087, 38.7534}, {86.1332, 38.7766}, {86.1491, 
  38.7918}, {86.1651, 38.8068}, {86.1976, 38.8378}, {86.2377, 
  38.8758}, {86.2779, 38.9136}, {86.2942, 38.9289}, {86.3347, 
  38.9672}, {86.359, 38.99}, {86.3834, 39.0129}, {86.3996, 
  39.0281}, {86.4157, 39.0432}, {86.432, 39.0585}, {86.4562, 
  39.0812}, {86.4723, 39.0963}, {86.4968, 39.1191}, {86.5211, 
  39.1418}, {86.5534, 39.1719}, {86.5781, 39.1947}, {86.6104, 
  39.2249}, {86.6347, 39.2472}, {86.668, 39.278}, {86.6841, 
  39.2931}, {86.7082, 39.3152}, {86.7248, 39.3306}, {86.741, 
  39.3455}, {86.7573, 39.3605}, {86.7736, 39.3756}, {86.7898, 
  39.3904}, {86.8066, 39.4058}, {86.8229, 39.4209}, {86.839, 
  39.4357}, {86.8554, 39.4506}, {86.872, 39.4658}, {86.8965, 
  39.4882}, {86.9126, 39.503}, {86.9294, 39.5183}, {86.9456, 
  39.5332}, {86.962, 39.5481}, {86.9784, 39.5631}, {86.9945, 
  39.5776}, {87.012, 39.5936}, {87.0259, 39.6062}, {87.0506, 
  39.6289}, {87.0446, 39.6248}, {86.9309, 39.6007}, {86.9319, 
  39.6008}, {87.1508, 39.7224}, {87.3654, 39.9241}, {87.5335, 
  40.0905}, {87.7128, 40.2768}, {87.884, 40.4632}, {88.0522, 
  40.6547}, {88.2157, 40.8498}, {88.3747, 41.0487}, {88.5293, 
  41.2511}, {88.6793, 41.4572}, {88.8248, 41.6666}, {88.9656, 
  41.8794}, {89.1018, 42.0955}, {89.2334, 42.3148}, {89.3602, 
  42.5372}, {89.4823, 42.7625}, {89.5998, 42.9908}, {89.7124, 
  43.2221}, {89.8204, 43.4563}, {89.9238, 43.6932}, {90.0224, 
  43.933}, {90.1166, 44.1757}, {90.2062, 44.4212}, {90.2914, 
  44.6696}, {90.3721, 44.9211}, {90.4486, 45.1757}, {90.5209, 
  45.4338}, {90.589, 45.6955}, {90.6533, 45.9612}, {90.7138, 
  46.2312}, {90.7706, 46.5062}, {90.8241, 46.7866}, {90.8742, 
  47.0734}, {90.9214, 47.3672}, {90.9658, 47.6697}, {91.0078, 
  47.9819}, {91.0476, 48.3054}, {91.0858, 48.6428}, {91.1226, 
  48.9961}, {91.1587, 49.3684}, {91.1948, 49.7634}, {91.2319, 
  50.1849}, {91.2709, 50.6391}, {91.3132, 51.1306}, {91.3612, 
  51.6697}, {91.4166, 52.2603}, {91.4833, 52.9137}, {91.5656, 
  53.6424}, {91.6703, 54.4657}, {91.7964, 55.3387}, {92.0805, 
  56.9426}, {92.525, 58.792}, {93.1174, 60.7094}, {93.799, 
  62.5189}, {94.5706, 64.2644}, {95.4121, 65.9257}, {96.3133, 
  67.5056}, {97.2625, 69.0023}, {98.2484, 70.4143}, {99.2639, 
  71.7454}, {100.3, 72.9955}, {101.351, 74.1696}, {102.407, 
  75.2641}, {103.468, 76.2902}, {104.527, 77.2461}, {105.572, 
  78.1298}, {106.613, 78.9553}, {107.636, 79.7175}, {108.645, 
  80.4243}, {109.63, 81.0735}, {110.596, 81.673}, {111.538, 
  82.2233}, {112.45, 82.725}, {113.345, 83.1891}, {114.208, 
  83.61}, {115.042, 83.9921}, {115.847, 84.3391}, {116.627, 
  84.6545}, {117.378, 84.9388}, {118.101, 85.1949}, {118.795, 
  85.4242}, {119.46, 85.6288}, {120.101, 85.8117}, {120.716, 
  85.9736}, {121.305, 86.1165}, {121.872, 86.2421}, {122.412, 
  86.3509}, {122.933, 86.4453}, {123.434, 86.5265}, {123.913, 
  86.5948}, {124.377, 86.6522}, {124.822, 86.6988}, {125.254, 
  86.736}, {125.677, 86.7646}, {126.082, 86.7846}, {126.475, 
  86.7968}, {126.87, 86.8018}, {127.251, 86.7998}, {127.625, 
  86.7909}, {128.011, 86.7748}, {128.167, 86.7663}, {128.19, 
  86.7649}, {128.947, 86.7163}, {129.704, 86.6611}, {130.46, 
  86.5993}, {131.215, 86.5309}, {131.97, 86.4559}, {132.724, 
  86.3743}, {133.478, 86.2862}, {134.23, 86.1915}, {134.982, 
  86.0902}, {135.733, 85.9823}, {136.483, 85.868}, {137.231, 
  85.747}, {137.979, 85.6196}, {138.726, 85.4856}, {139.471, 
  85.3451}, {140.215, 85.1981}, {140.958, 85.0447}, {141.7, 
  84.8847}, {142.44, 84.7183}, {143.178, 84.5454}, {143.915, 
  84.3661}, {144.651, 84.1804}, {145.384, 83.9883}, {146.116, 
  83.7897}, {146.847, 83.5848}, {147.575, 83.3735}, {148.302, 
  83.1559}, {149.027, 82.9319}, {149.749, 82.7016}, {150.47, 
  82.4651}, {151.189, 82.2222}, {151.905, 81.9731}, {152.619, 
  81.7177}, {153.331, 81.4561}, {154.041, 81.1884}, {154.748, 
  80.9144}, {155.453, 80.6343}, {156.156, 80.348}, {156.855, 
  80.0556}, {157.553, 79.7571}, {158.247, 79.4525}, {158.939, 
  79.1419}, {159.629, 78.8253}, {160.315, 78.5026}, {160.999, 
  78.174}, {161.68, 77.8394}, {162.357, 77.4989}, {163.032, 
  77.1525}, {163.704, 76.8003}, {164.373, 76.4421}, {165.038, 
  76.0782}, {165.7, 75.7084}, {166.359, 75.3329}, {167.015, 
  74.9517}, {167.668, 74.5647}, {168.317, 74.1721}, {168.962, 
  73.7738}, {169.604, 73.3699}, {170.243, 72.9604}, {170.877, 
  72.5454}, {171.509, 72.1248}, {172.136, 71.6988}, {172.76, 
  71.2672}, {173.38, 70.8303}, {173.996, 70.388}, {174.609, 
  69.9402}, {175.217, 69.4872}, {175.821, 69.0289}, {176.422, 
  68.5653}, {177.018, 68.0965}, {177.61, 67.6225}, {178.198, 
  67.1434}, {178.782, 66.6592}, {179.362, 66.1698}, {179.937, 
  65.6755}, {180.508, 65.1761}, {181.074, 64.6718}, {181.637, 
  64.1625}, {182.194, 63.6484}, {182.747, 63.1294}, {183.296, 
  62.6056}, {183.84, 62.0771}, {184.38, 61.5438}, {184.914, 
  61.0058}, {185.444, 60.4632}, {185.97, 59.916}, {186.49, 
  59.3642}, {187.006, 58.8079}, {187.516, 58.2471}, {188.022, 
  57.6819}, {188.523, 57.1122}, {189.019, 56.5383}, {189.51, 
  55.96}, {189.996, 55.3775}, {190.476, 54.7907}, {190.952, 
  54.1998}, {191.422, 53.6048}, {191.888, 53.0056}, {192.347, 
  52.4025}, {192.802, 51.7953}, {193.251, 51.1842}}

I plotted these point in Mathematica.

enter image description here

And after checked and zoom in, I get "abnormality point"as shown below

enter image description here

How to make logic (loop) for detecting this"abnormality point" and remove it from data points? so that the curve will be smooth.

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ This and your other question (mathematica.stackexchange.com/questions/147446/…) seem to request competely data-driven solutions with no subject matter considerations. Are there at least guesses as to why the data has these "oddities"? As noted below the x-values are not in sorted order and there are two points with nearly the same x and y values associated with the oddity. Is this some explainable instrument hiccup? $\endgroup$
    – JimB
    Jun 4, 2017 at 20:46
  • $\begingroup$ @JimBaldwin I don't know why it happened. And that's the reason why I try to detect and remove it using programming. $\endgroup$
    – SelfA
    Jun 5, 2017 at 1:09

3 Answers 3

Reset to default
3
$\begingroup$

This is somewhat too ad-hoc, but works in this case:

data = {data points in the question}

Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/QuantileRegression.m"]

qfunc = QuantileRegression[data, 40, {0.5}][[1]];

outlierPoints = 
  Select[data, Abs[#[[2]] - qfunc[#[[1]]]] > (0.001 #[[2]]) &];
outlierPoints // Length
(* 55 *)

Show[
 ListLinePlot[{data, {#, qfunc[#]} & /@ data[[All, 1]]}, 
  PlotRange -> {{85, 88}, {38, 40}}],
 ListPlot[outlierPoints, PlotStyle -> Red]
 ]

enter image description here

It is probably a good idea to see other discussions about outlier detection and Quantile regression at MSE.

Improve this answer
$\endgroup$
1
$\begingroup$

Listplot is abnormal because x values of your data are not fully in ascending order.

To restore ascending order, you can remove all elements which have negative difference of the x component compared to the previous element. You may need to repeat this removing procedure until all differences for all elements are positive:

removeNegDiffElements[data_?MatrixQ] := Pick[data, 
    Join[{1}, Sign@Differences@First@Transpose@data], 1];
removeAllNegDiffElements[data_?MatrixQ] := FixedPoint[removeNegDiffElements, data];

For your data:

ListPlot[{data, removeAllNegDiffElements[data]},
    PlotRange -> {{86.8, 87.4}, {39.2, 40}}, 
    Joined -> True, 
    Mesh -> Full]

Plot without abnormality

Improve this answer
$\endgroup$
6
  • $\begingroup$ I've tried to apply your suggestion program (copy and paste) in my mathematica program but it is unsuccessful running. do you have any sugestion? because I am newbie in this field. Thank You $\endgroup$
    – SelfA
    Jun 5, 2017 at 2:13
  • 1
    $\begingroup$ @SelfA Sorry, I have corrected a typo in the code. Before you evaluate the code you should also define data = {all your data points here}. $\endgroup$
    – Ray Shadow
    Jun 5, 2017 at 11:02
  • $\begingroup$ @SelfA I also forgot to add that line, data = {all your data points here}, in my post. $\endgroup$
    – Anton Antonov
    Jun 5, 2017 at 11:13
  • $\begingroup$ @Shadowray Thank you. It's work. By the way, I'am still thinking if any others case is as close as with this case but I want to remove all elements which have positive difference of the x component compared to the previous element. so, what should be modified for following your programming above? $\endgroup$
    – SelfA
    Jun 8, 2017 at 7:27
  • $\begingroup$ You can change Pick[data, Join[{1}, Sign@ Differences@ First@ Transpose@ data], 1] to Pick[data, Join[{-1}, Sign@ Differences@ First@ Transpose@ data], -1]. $\endgroup$
    – Ray Shadow
    Jun 8, 2017 at 7:42
1
$\begingroup$

I want to ensure I have a robust solution, so I will use the data below which has several outliers.

data = Join[Array[0.01 # {Cos@#, Sin@#} &, 400, {0.0, 8.0 Pi}], 
  Array[{0.5025, 0.003} - 0.01 # {Cos@#, Sin@#} &, 400, {8.0 Pi, 0.0}]
];
Part[data, 33] = {-0.0041, 0.04};
Part[data, 128] = {-0.024, 0.11};
Part[data, 225] = {0.0, 0.18};
Part[data, 326] = {0.05, 0.22};
Part[data, 352] = {-0.33, -0.03};
Part[data, 366] = {-0.25, -0.23};
Part[data, 375] = {0.0, -0.35};
Part[data, 450] = {0.85, 0.01};
Part[data, 475] = {0.4, -0.24};
Part[data, 574] = {0.58, -0.145};
Part[data, 673] = {0.5, -0.099};
ListLinePlot[data, AspectRatio -> Automatic, Axes -> None]

original data

Next, I determine which samples have sharp corners. The symbol sharpCorners below is 1 when the respective sample is a sharp corner, and 0 when the respective sample is not a sharp corner. I also determine the samples at positions 325, 475, 573 have two adjacent sharp corners due to one outlier.

directionList = ArcTan @@@ Differences@data;
sharpCorners = Unitize@Clip[Abs@Differences@directionList, 
   {Pi*5/6, Pi*7/6}, {0, 0}];
   twinSharpCornerPositions = 1 + Flatten@Position[Partition[sharpCorners,
   2, 1], {1, 1}]
(*{325,475,573}*)

Below, samples 475 and 476 are Red and Green respectively. I also define a function 'pickOutlierPositions' to determine which of adjacent samples that both have a sharp corner. 

ListLinePlot[data, AspectRatio -> Automatic, 
  PlotRange -> {{0.4, 0.638}, {-0.25, -0.16}}, Axes -> None, 
  Epilog -> {AbsolutePointSize@5, Point@data, Red, 
  Point@Part[data, 475], Green, Point@Part[data, 476]}
]

Cose-up on samples

pickOutlierPositions = 
   Compile[{{data, _Real,2}, {twinSharpCornerPositions, _Integer,1}},
   Module[{x1, y1, x2, y2, x3, y3, x4, y4}, 
   Table[{{x1, y1}, {x2, y2}, {x3, y3}, {x4, y4}} = 
   Take[data, {posn - 1, posn + 2}];
   With[{d23Squared = (x3 - x2)^2 + (y3 - y2)^2},
     If[Max[d23Squared, (x2 - x1)^2 + (y2 - y1)^2] > 
        Max[d23Squared, (x4 - x3)^2 + (y4 - y3)^2],
        posn,(* else *)posn + 1
     ]
  ], {posn, twinSharpCornerPositions}]
]];

signleSharpCornerPositions = 
  Complement[1 + Flatten@Position[sharpCorners, 1], 
  twinSharpCornerPositions, 1 + twinSharpCornerPositions];
outlierPositions = Join[signleSharpCornerPositions, 
   pickOutlierPositions[data, twinSharpCornerPositions]
]
(*{33,128,225,352,366,375,450,673,326,475,574}*)

Above, I found the samples at positions 325, 475, 573 have sharp corners, and are also adjacent to samples with sharp corners. The output above says samples 326, 475, 574 are outliers. Next, I remove the samples that are outliers by replacing them with the expression Sequence[]. After the outliers are removed, the curve is smooth.

Part[data, outlierPositions] = Sequence[];
ListLinePlot[data, AspectRatio -> Automatic, Axes -> None]

smoothed data

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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