Separating clustering data and interpolating as smooth curves

Question

I have a list of data (3kB) in the form of {x,y}. For some x values, every x corresponds to a single y, for some others, every x corresponds to $3$ different y. Please see the following plot.

testpts = Import["~\\curves_test.dat"];
plt = ListLogPlot[testpts, PlotRange -> All, ImageSize -> 300, Frame -> True, Axes -> False]

As you may see, there are actually two curves, one of which is folding (see the orange curve in the figure below). I would like to separate the data and interpolate them as two different smooth curves, such that I can plot them respectively. For example, this enables us to plot the two curves in different figures with Plot and LogPlot or with different PlotStyles, as illustrated in the desired results.

Notes

1. The data are obtained from numerical calculation. The red and orange curves do not intersect (thanks to @JimB's advice). They look very close in a range (around 2.94<x<2.99) but actually well separated.

2. Some parts of the data look not very smooth, thus I'd like to make them smooth somehow with appropriate interpolate functions.

3. I need a general approach to handle lots of data with such kind of features, thus picking out data with Select[testpts, x1 < First@# < x2 && y1 <Last@# <y2 &] may not be very useful :)

Any suggestions are welcome!

Answer 1

Assuming the data has been imported in the variable "d" and that the second curve is always above the first one. The curves are then:

d1 = Select[
   d, (tmp = Cases[d, {#[[1]], _}]; 
     If[Length[tmp] == 
        1 || (Length[tmp] > 1) && #[[2]] == Min[tmp[[All, 2]]], True, 
      False]) &];
d2 = Complement[d, d1];
ListPlot[{d1, d2}]

Next we need to smooth the curves. This is easy for d1:

d1s = Transpose[{d1[[All, 1]], LowpassFilter[d1[[All, 2]], 0.5]}];
ListPlot[d1s]

This is more difficult for d2 because the points are not in sequence. Therefore we need to reorder d2 before smoothing:

d2 = Complement[d, d1];
last = d2[[-1]];
d2l = Reap[
    Do[Sow[last = Nearest[d2 = DeleteCases[d2, last], last][[1]]], {i,
       2, Length[d2]}]
    ][[2, 1]] ;
d2s = Transpose[{d2l[[All, 1]], LowpassFilter[d2l[[All, 2]], 0.5]}];
ListPlot[d2s, PlotRange -> {{2.9, 2.99}, {0, 0.1}}]

Answer 2

Not general, not elegant, but I think it solves your immediate problem.

(data is your data)

gg = GroupBy[data, First]

Pick out the minimum values if there are multiple points:

bottomCurve = Values[First /@ Sort /@ gg];

Remove those points from your data set:

topCurve = First[ data /. {Thread[bottomCurve -> Nothing]}]

A simple brute force method is to fit to a line and then separate the upper and lower branches by being above or below the line:

fit = FindFit[topCurve, a x + b, {a, b}, x]
linFit = (a x + b) /. fit

topBranch = Cases[topCurve, {a_, b_} /; (b >= linFit /. x :> a)]
botBranch = Cases[topCurve, {a_, b_} /; (b < linFit /. x :> a)]

Show[ListPlot[bottomCurve, PlotStyle -> Red], 
 ListPlot[topBranch, PlotStyle -> Blue], ListPlot[botBranch]]

If you want to stitch the two branches:

topJoinedCurve = Join[Reverse[topBranch], botBranch]
Show[ListPlot[bottomCurve, PlotStyle -> Red], 
 ListLinePlot[topJoinedCurve]]