How can I obtain a smooth curve from my data but preserve two inversion points

Question

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.

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 :).

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

Answer 1

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

Answer 2

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:

I'll try to post some code later.

Answer 3

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

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: