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

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[]]], data[[curvetest[]]]}, 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!

• Well, if you have a data set, let's say data = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; then you can use data[[;; 5]] to pick the first five ones for example. Similarly, data[[5 ;;]] gives the last five entries of the original list. So, maybe you can use that to separate data and do your fits. Jan 18, 2022 at 14:05

We can divide data into two list as follows

up = Select[data, #[] >= data[[2, 2]] &];
dw = Select[data, #[] <= 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 /@
Length[data]; l =
Interpolation[{data[], (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, #[] >= l[#[]] &];

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

{ListPlot[{up, dw}, PlotStyle -> {Blue, Green}],ListLinePlot[{up, dw}, Mesh -> All, MeshStyle -> Red,
PlotRange -> {{1.88, 2.2}, {0.39, 0.42}}, PlotStyle -> Blue]} • Sorry, your method is not reliable because some points are lost, for example, the 2nd and 3rd point {1.9, 0.4114} and {1.905, 0.41145} should have been included in up.
– lxy
Jan 19, 2022 at 2:53
• @jsxs See update to my answer. Jan 19, 2022 at 10:04

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[]]
f2 = Interpolation[data[]]

Plot[{f1[x], f2[x]}, {x, Min[d0[[All, 1]]], Max[d0[[All, 1]]]}] • Thank you very much! Your method works exactly for the particular case. However, for my real problem, the data do include a number of bugs, that is, for some x it does not have a pair. Is there a more robust method that can tolerate the exceptions without the deleting process like Alex's method?
– lxy
Jan 19, 2022 at 3:12
• @jsxs it seems that would be a good question to make a new post about! That is, how to fix your data’s exceptions issues with a general method. After waiting a bit longer, I would recommend you accept your preferred answer for this question, and continue your path with the second question. I recommend waiting because someone may come along give an answer that includes this additional level of complexity you mention in the comments. Jan 19, 2022 at 4:49