3
$\begingroup$

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:

enter image description here

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?

$\endgroup$
2
$\begingroup$

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]

enter image description here

| improve this answer | |
$\endgroup$
2
$\begingroup$

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

enter image description here

| improve this answer | |
$\endgroup$
1
$\begingroup$

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

ListCurvePathPlot[y, AspectRatio -> 1/GoldenRatio]

enter image description here

Note that the curves correspond to the output of FindCurvePath:

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

enter image description here

| improve this answer | |
$\endgroup$
  • $\begingroup$ Thank you for the helpful answer. Any idea why there is that set back in the gold plot? $\endgroup$ – Jorge Apr 3 '19 at 20:23
1
$\begingroup$

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.

plot1

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

plot2

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.

plot3

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

plot4

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.

plot5

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

plot6

| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.