Plot two smooth curves from a set of data with interlaced points

Question

I have a set of data which was obtained from numerical calculation. The plot of the original data is as follows (the data is 26Kb only).

data = ToExpression /@ Import["~\\testdata.csv"];
ListPlot[data, PlotRange -> All]

The data consist of interlaced points as can be seen in the enlarged view

ListLinePlot[data, Mesh -> All, MeshStyle -> Red, PlotRange -> {{1.88, 2.2}, {0.39, 0.42}}]

I hope to plot smooth curves to approximate these points and have tried FindCurvePath

curvetest = FindCurvePath[data];
Curvetest = ListLinePlot[{data[[curvetest[[1]]]], data[[curvetest[[2]]]]}, Frame -> True, Axes -> False, PlotRange -> All]

It gives two smooth curves, but near the left and right interactions, some parts are lost in comparison with the original plot. I guess this could result from the points jumping up and down near the intersections and FindCurvePath cannot distinguish the rapid jump there.

I have an idea to deal with this: (1) separate the data for the upper and lower curves, and (2) use FindCurvePath or some other method (e.g. Fit) to plot two smooth and complete curves. But I have trouble in the first step. Can anyone help with this? Thank you!

Answer 1

We can divide data into two list as follows

up = Select[data, #[[2]] >= data[[2, 2]] &];
dw = Select[data, #[[2]] <= data[[1, 2]] &];

Now we can plot

{ListPlot[{up, dw}, PlotStyle -> Blue],
ListLinePlot[{up, dw}, Mesh -> All, MeshStyle -> Red, 
 PlotRange -> {{1.88, 2.2}, {0.39, 0.42}}, PlotStyle -> Blue]}

Update 1. Second method based on hypothesis that there is a line dividing region on two parts and separating curves as follows

data = ToExpression /@ 
  Import["C:\\Users\\troun\\Downloads\\testdata.csv"]; n = 
 Length[data]; l = 
 Interpolation[{data[[1]], (data[[n]] + data[[n - 1]])/2}, 
  InterpolationOrder -> 1];
Show[ListPlot[data, PlotRange -> All], 
 Plot[l[x], {x, data[[1, 1]], First[(data[[n]] + data[[n - 1]])/2]}, 
  PlotStyle -> Orange]]

up = Select[data, #[[2]] >= l[#[[1]]] &];

dw = Select[data, #[[2]] <= l[#[[1]]] &];

{ListPlot[{up, dw}, PlotStyle -> {Blue, Green}],ListLinePlot[{up, dw}, Mesh -> All, MeshStyle -> Red, 
 PlotRange -> {{1.88, 2.2}, {0.39, 0.42}}, PlotStyle -> Blue]}

Answer 2

Note that your data contains 2 y values for every x value. However, there is a bug, the exception is the 69'th point that does not have a pair. therefore delete point 69:

data = d0 = ToExpression /@ Import["d:/Downloads/testdata.csv"];
data = Delete[data, 69];

Now we separate the 2 curves using "Partition" and "Transpose":

data = Transpose[Partition[data, 2]];

Now we can interpolate and plot the resulting functions:

f1 = Interpolation[data[[1]]]
f2 = Interpolation[data[[2]]]

Plot[{f1[x], f2[x]}, {x, Min[d0[[All, 1]]], Max[d0[[All, 1]]]}]