6
$\begingroup$

I have a list of data points, {x, y}, my data. When I plot them, the curve is jagged. I want to smooth the curve and preserve the two sharp corners. This is a plot of the raw data.

enter image description here

I have tried using low pass filters for a week, but the curve is still not very good.

data = Import["C:\\Users\\...\\Desktop\\my_data.dat"];
  (*... denotes your name or so, pls import my data first *)
yy1 = Select[data, First @ # < 3.423 &]; 
  (*get the data whose x < position of the first sharp *)
yy2 = Select[data, 3.423 < First @ # < 5.467 &]; 
  (*get the data whose x between the two sharps *)
yy3 = Select[data, 5.467 < First @ # &]; 
  (*get the data whose x > position of the second sharp *)
ListPlot @ Join[yy1, yy2, yy3]

My curve has lots of zigzags. The following is my low pass filter function.

smooth[data_, res_] := With[{
x = Map[First, data],
y = Map[Last, data],
len = Length@data},
Manipulate[
  ListLinePlot @ (res = Thread[{x, LowpassFilter[y, ω, len]}]),
  {{ω, 0.2}, 0, 0.5, 0.001}]]
Clear[rest1, rest2, rest3]
smooth[#, rest1] & @ yy1
smooth[#, rest2] & @ yy2
smooth[#, rest3] & @ yy3

After evaluating the above code, I can smooth the three parts of the zigzag curve separately. Then I combine them.

end = (restFinal = Join[rest1, rest2, rest3]) // ListLinePlot

As I said, the curve still doesn't look good enough. Some parts are changed inappropriately! What I want is something like this, which has been obtained by making a drawing :).

enter image description here

I just want to use some Mathematica plot tricks or some other approach that give me the smooth curve I am seeking.

$\endgroup$
4
  • $\begingroup$ You can try MovingAverage but that will change some features; for instance, the inversion points will not reach 0. $\endgroup$ Oct 10, 2014 at 13:24
  • $\begingroup$ Hi, @b.gatessucks, thank you for your reply. I have tried the MovingAverage just now, it do can make my curve smooth, but make my two inversion points away from zero. I just want to maintain the two inversion points as well as make the other part smooth. :) $\endgroup$
    – Enter
    Oct 10, 2014 at 13:43
  • $\begingroup$ An adaptive Laguerre smoothing technique may give you just what you need. See below... $\endgroup$
    – Jagra
    Oct 10, 2014 at 14:00
  • $\begingroup$ Any objection to using Piecewise[]? $\endgroup$ Oct 10, 2014 at 14:22

3 Answers 3

8
$\begingroup$

Why not try to fit some functions to your three datasets? Using Fit we can fit e.g. polynomials of degree 10 as follows:

FitPolynomial[data_] := Fit[data, Table[x^n, {n, 0, 10}], x];

{f1, f2, f3} = FitPolynomial /@ {yy1, yy2, yy3};

We can then combine the three functions f1, f2, and f3 into a single function f with PieceWise:

f = Piecewise @ {
  {f1, 0 < x < 3.423},
  {f2, x < 5.467},
  {f3, x < 8.886}
};

Finally, we find a nice smooth curve by plotting f:

Plot[f, {x, 0, 8.886}]

Mathematica graphics

$\endgroup$
3
$\begingroup$

Just an extended comment to start. I'll try to follow up with some code later today or over the weekend.

This sounds like a perfect job for a Laguerre Filter and most likely an adaptive one, e.g., Laguerre Filters – An Introduction. You can find lots of info on this online.

The Laguerre Filter smooths a data set based on Laguerre polynomials. Its first term, an Exponential Moving Average, followed by certain feedback terms. The smoothing gets controlled by an alpha factor (the alpha for the Exponential Moving Average) and also damps the further terms. Alpha can range from 1 to follow the data almost exactly to 0 for a very slow response.

The result gives weighted average of past values.

An adaptive laguerre filter introduces a variable alpha factor based on how well the filter tracks the past N values. This should enable the the filter to follow the data quite closely as it changes character over the span of the x axis.

Mathematica's LaguerreL function may make this quite easy. From the documentation:

LaguerreL documentation

I'll try to post some code later.

$\endgroup$
1
  • $\begingroup$ Hi, @Jagra! Thank you for your interesting! I will also try it! I am thinking that MovingAverage may do this job perfectly if we can control the weight to do the average at the oscillating part and follow my curve near the two inversion points. As you can see, with my LowpassFilter or @kale's GaussianFilter, there is an inappropriate change in the right part of the curve, where the original curve is smooth or good enough. $\endgroup$
    – Enter
    Oct 10, 2014 at 14:14
3
$\begingroup$

Here's a rather ham-fisted approach using GaussianFilter:

First, a filtering function:

filter[data_, threshold_, r_] := 
 Module[{datatemp = Transpose@data, 
  pos = Flatten@Position[data[[All, 2]], x_ /; x >= threshold]},
 datatemp[[2, pos]] = GaussianFilter[datatemp[[2, pos]], r];
 Transpose@datatemp
]

This function applies a Gaussian filter to all the data greater than a certain y-value.

We can use it like so:

ListLinePlot[filter[data, 0.01, 20]]

enter image description here

To play with the values, we can build a simple Manipulate program:

Manipulate[
 ListLinePlot[filter[data, t, r]],
 {{t, 0.01}, 0, 0.6}, {{r, 20}, 0, 20}]

UPDATE

I think the WienerFilter performs better:

enter image description here

$\endgroup$
2
  • $\begingroup$ Thanks @kale! As you can see, with my LowpassFilter or your GaussianFilter, there is both an inappropriate change in the right part of the curve, where the original curve is smooth or good enough. I think your WienerFilter is relatively good. But we can still improve it. Could you pls post your WienerFilter code? $\endgroup$
    – Enter
    Oct 10, 2014 at 14:21
  • $\begingroup$ @Ixy Just replace GaussianFilter with WeinerFilter. $\endgroup$
    – kale
    Oct 10, 2014 at 14:22

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.