Ordering the elements in a list and separate them into sublists for plotting

Question

I want to plot the following data:

 y={{0., 2.14557}, {0.1, 2.14589}, {0.2, 2.14686}, {0.3, 2.14852}, {0.4, 
  2.15092}, {0.5, 2.15415}, {0.6, 2.15834}, {0.7, 2.16363}, {0.8, 
  2.17025}, {0.9, 2.17844}, {1., 2.1885}, {1.1, 2.20076}, {1.2, 
  2.10506}, {1.3, 2.11519}, {1.4, 2.12737}, {1.5, 2.14122}, {1.6, 
  2.15726}, {1.7, 2.17674}, {1.8, 2.2012}, {1.9, 2.10502}, {2., 
  2.13057}, {2.1, 2.28359}, {2.2, 2.18106}, {1.2, 2.21549}, {1.3, 
  2.23277}, {1.4, 2.25188}, {1.5, 2.27083}, {1.9, 2.23041}, {2., 
  2.26034}, {2.1, 2.28359}}

I was thinking of plotting the data with ListLinePlot, so I have something like:

I tried to order it into three different lists, like

y = {{list1}, {list2}, {list3}}

where list1 corresponds to the first plotted line, list2 to the second and list3 to the third, so it would be easier to separate them and plot them. However, I couldn't do it successfully.

How can I achieve this? Is there a more intelligent/convinient way to plot the list y?

Answer 1

A simple linear classifier, but a complete kludge and not generalizable:

aa = Select[y, #[[2]] > 2.025 + .15 #[[1]] &];
cc = Select[y, #[[2]] < 1.8 + .2 #[[1]] &];
bb = Complement[y, Union[aa, cc]];
ListPlot[{aa, bb, cc},
PlotMarkers -> Automatic,
Joined -> True]

Answer 2

An attempt based on Nearest. This is not generalizable either - it only works if the desired groups are monotonically increasing, and the inter-group distances are greater than the intra-group distances. (And probably other conditions that I haven't foreseen.)

lnum = 1;
y = Sort[y, #1[[1]] < #2[[1]] &];
p = y[[1]];
newl = {{p}};
Do[
  {
   y = DeleteCases[y, p];
   nextp = Nearest[y, p][[1]];
   If[nextp[[2]] >= p[[2]],
    {AppendTo[newl[[lnum]], nextp]}, 
    {
      AppendTo[newl, {}],
      lnum++,
      nextp = First[y],
      AppendTo[newl[[lnum]], nextp]
      };
    ];
   p = nextp;
   }, {Length[y] - 2}];

ListPlot[newl, Joined -> True, PlotMarkers -> Automatic, PlotStyle -> {Red, Orange, Green}]

Answer 3

Doesn't work perfectly, but you could try ListCurvePathPlot:

ListCurvePathPlot[y, AspectRatio -> 1/GoldenRatio]

Note that the curves correspond to the output of FindCurvePath:

ListLinePlot[y[[#]]& /@ FindCurvePath[y]]

Answer 4

Maybe I'm tilting at a windmill — I have to admit that I sometimes enjoy doing that — but I would like to make a case for a solution, which uses an approach the combines aspects of @CarlWoll's and @DavidG.Stork's work, but argues for a different final result.

The data.

y =
  {{0., 2.14557}, {0.1, 2.14589}, {0.2, 2.14686}, {0.3, 2.14852}, {0.4, 2.15092}, 
   {0.5, 2.15415}, {0.6, 2.15834}, {0.7, 2.16363}, {0.8, 2.17025}, {0.9, 2.17844}, 
   {1., 2.1885}, {1.1, 2.20076}, {1.2, 2.10506}, {1.3, 2.11519}, {1.4, 2.12737}, 
   {1.5, 2.14122}, {1.6, 2.15726}, {1.7, 2.17674}, {1.8, 2.2012}, {1.9, 2.10502}, 
   {2., 2.13057}, {2.1, 2.28359}, {2.2, 2.18106}, {1.2, 2.21549}, {1.3, 2.23277}, 
   {1.4, 2.25188}, {1.5, 2.27083}, {1.9, 2.23041}, {2., 2.26034}, {2.1, 2.28359}};

It's true that a simple list plot of the data suggests the data represents three curves.

But, when the Joined -> True, is added, it is seen that the data ordering does not support this.

So I tell Mathematica to find a better ordering. I also abandon ListPlot and change over to Graphics.

Module[{pts, groups, lines},
  pts = Point[y];
  groups = y[[#]] & /@ FindCurvePath[y];
  lines = Line[Partition[#, 2, 1]] & /@ groups;
  Graphics[{{Thick, lines}, {AbsolutePointSize[8], pts}},
  AspectRatio -> 1/GoldenRatio, Axes -> True]] 

getting, basically, the same result as Carl Well.

Now I add some code to remove the unwanted long connections that appear to join the 2nd and 3rd curves.

plot =
  With[{max = .14},
    Module[{pts, groups, lines},
      pts = Point[y];
      groups = y[[#]] & /@ FindCurvePath[y];
      lines =
        Line[
          Partition[#, 2, 1] // Select[EuclideanDistance[#[[1]], #[[2]]] < max &]] & 
        /@ 
          groups;
      Graphics[{{Thick, lines}, {AbsolutePointSize[8], pts}},
        AspectRatio -> 1/GoldenRatio, Axes -> True]]]

You will, of course, notice there is an isolated point. It's there because there is no value of max that will attach the point to the 3rd curve without also attaching it to the 2nd curve. The isolated point is closer the 2nd curve than to the 3rd curve. It doesn't look that way in the plot because the y-axis is being stretched by Mathematica to get a nice looking plot. Here is the plot with isometric scaling.

Should that convict you, here are actually distance values.

Module[{pts, groups, lines},
  pts = Point[y];
  groups = y[[#]] & /@ FindCurvePath[y];
  lines = Line[Partition[#, 2, 1]] & /@ groups;
  EuclideanDistance[#[[1]], #[[2]]] & /@ lines[[2, 1, {-3, -2}]]]

{0.143222, 0.206275}

Although I personally would go for the isolated point, should that not be acceptable to you, I hope this post makes a convincing argument that to join the curves in the following alternative way:

With[{max = .15},
  Module[{pts, groups, lines},
    pts = Point[y];
    groups = y[[#]] & /@ FindCurvePath[y];
    lines =
      Line[Partition[#, 2, 1] // Select[EuclideanDistance[#[[1]], #[[2]]] < max &]] & 
      /@ 
        groups;
    Graphics[{{Thick, lines}, {AbsolutePointSize[8], pts}},
      AspectRatio -> Automatic, Axes -> True]]]