8
$\begingroup$

This is my code:

list = {{1368, 1398}, {1399, 1402}, {1403, 1424}, {1424, 1425}, 
        {1426, 1435}, {1436, 1449}, {1450, 1457}, {1457, 1464}, 
        {1465, 1487}, {1488, 1505}, {1506, 1521}, {1522, 1566}, 
        {1567, 1572}, {1573, 1620}, {1620, 1620}, {1621, 1627}, 
        {1628, 1644}};

ListPlot[
  Table[
    Callout[{0, -First[i]}, First[i], Left, LabelVisibility -> All],
    {i, list}
  ],
  Axes->False
]

plot with overlapping labels

Notice that two points are very close to each other, which causes their labels to overlap. I really don't want to set the coordinates of a point separately. Is there an elegant way to automatically avoid the overlap of their labels?

$\endgroup$

3 Answers 3

5
$\begingroup$

The question may seem a Convex quadratic minimization with linear constraints:

$$\begin{align}\mathrm{minimize}&\; \sum_\limits{i=1}^n{(x_i-a_i)^2}\\\mathrm{subject\;to}&\; x_{i+1}-x_i>h,\;i=1,2,\cdots,n-1\end{align}$$

there, $a_i$ is known data in your "list", $x_i$ is the appropriate position of label $a_i$.

It's easy to solve $x_i$ with the function "FindArgMin" in Mathematica.

But I can't find out a self-adaption font-size in the function "Style".

enter image description here

(*define function: join line*)
line[pLeft_, pRight_] := 
  With[{meanX = Mean[{pLeft[[1]], pRight[[1]]}]},
   BezierCurve[{pLeft, {meanX, pLeft[[2]]}, {meanX, pRight[[2]]}, 
     pRight}]];

(*define function: show label*)
showLabel[yData_, label_, labelH_, labelS_, imageHeight_, left_ : 0, 
   right_ : 100] := Block[{
    n = Length[yData],
    y = Sort[yData],
    vX, ySolve, minmax, scale, object, condition
    },
   (*solve appropriate position*)
   vX = ToExpression["x" <> ToString[#] & /@ Range[n]];
   object = Total[(vX - y)^2];
   condition = And @@ (# > labelH + labelS & /@ Differences[vX]);
   ySolve = FindArgMin[{object, condition}, vX];
   
   (*sacle*)
   minmax = MinMax[Flatten[{y, ySolve}]];
   scale = imageHeight/Differences[minmax][[1]];
   
   (*Show*)
   Graphics[{
     {(*right vertical line*)
      Opacity[0.5], AbsoluteThickness[1], Gray, 
      Line[{{right, minmax[[1]]}, {right, minmax[[2]]}}]},
     {(*join line*)
      Opacity[0.5], AbsoluteThickness[1], Gray, 
      Table[line[{left, ySolve[[k]]}, {right, y[[k]]}], {k, n}]},
     {(*right data point*)
      RGBColor["#1d3557"], AbsolutePointSize[3], 
      Point[{right, #} & /@ y]},
     {(*decorate point*)
      White, AbsolutePointSize[4], Point[{left, #} & /@ ySolve]},
     {(*label*)
      RGBColor["#457b9d"], 
      Table[Inset[
        Framed[Style[label[[k]], 8], RoundingRadius -> 2, 
         FrameMargins -> Tiny, ImageSize -> {Automatic, scale labelH},
          Background -> RGBColor["#f1faee"]], {left, ySolve[[k]]}, 
        Right], {k, n}]}
     },
    ImageSize -> {Automatic, imageHeight},
    PlotRange -> {Automatic, minmax + {-labelH, labelH}}]
   ];

(*Demo*)
y = Sort[RandomReal[{0, 1000}, 15]];
showLabel[y, y, 30, 5, 500, 0, 100]

The code and image for your data:

list = {{1368, 1398}, {1399, 1402}, {1403, 1424}, {1424, 1425}, {1426,
     1435}, {1436, 1449}, {1450, 1457}, {1457, 1464}, {1465, 
    1487}, {1488, 1505}, {1506, 1521}, {1522, 1566}, {1567, 
    1572}, {1573, 1620}, {1620, 1620}, {1621, 1627}, {1628, 1644}};
y = Sort[list[[;; , 1]]];
showLabel[y, y, 12, 3, 400, 0, 30]

![enter image description here

$\endgroup$
1
  • $\begingroup$ This is very nice! $\endgroup$
    – MarcoB
    2 hours ago
6
$\begingroup$

The code below distributes the labels on either sides of the plot points, trying to ensure that labels for values that are very close end up on opposite sides. I also "cheated" a little by increasing the AspectRatio: this got me some more vertical space and improved the vertical separation between labels that were still too close even after the left-right separation.

threshold = 50;
values = list[[All, 1]];

left = 
  First[#, #] & /@ 
    DeleteDuplicatesBy[Nearest[values, values, {2, threshold}], Sort];

right = Complement[values, left];

annotated = 
  MapThread[
    Function[{list, position},
      Callout[
        {0, -#}, #,
        position, LabelVisibility -> All
      ] & /@ list],
     {{left, right}, {Left, Right}}
  ];

ListPlot[
  annotated,
  Axes -> False, PlotStyle -> Black,
  AspectRatio -> 1.1
]

same plot, but better vertical separation of the labels


Here is an alternative presentation that retains all labels on the left of the data, but differentiates them using short vs. long leaders in the Callout:

short = left; long = right;

annotated2 =
  MapThread[
    Function[{list, length},
      Callout[
        {0, -#}, #,
        Left, LabelVisibility -> All, 
        LeaderSize -> length
      ] & /@ list
    ],
    {{short, long}, {10, 50}}
  ];

ListPlot[
  annotated2,
  Axes -> False, PlotStyle -> Black,
  AspectRatio -> 2
]

close data points are given leaders of different length, but all labels are on left hand side of points

$\endgroup$
6
  • $\begingroup$ Hi, thanks for your answer. But all labels should be on left, which is important for me. $\endgroup$
    – yode
    Jun 20 at 1:57
  • $\begingroup$ @yode Sure would have been nice to know that beforehand! But if you want the labels on the same side, what other solution do you envision apart from just stretching the aspect ratio to make more space vertically? I guess you could also use my data splitting code to make the callout leaders longer for some of the labels, but keep them all on the same side. Would that be acceptable, if it can be done? $\endgroup$
    – MarcoB
    Jun 20 at 2:22
  • $\begingroup$ Yes, I can accept longer leaders. $\endgroup$
    – yode
    Jun 20 at 2:44
  • $\begingroup$ What is your values? $\endgroup$
    – yode
    Jun 20 at 4:56
  • $\begingroup$ @yode Added, sorry for the omission. It's just list[[All, 1]] $\endgroup$
    – MarcoB
    Jun 20 at 5:08
2
$\begingroup$

In fact I think avoiding overlap is a function that the Callout itself needs to implement. I have make workaround:

box = {};
ListPlot[Table[dist = Min[
    EuclideanDistance[#, {0, -First[i]} - {0.06, 0}] & /@ box]; 
  If[dist < 7, pos = {0, -First[i]} - {0.06, 7 - dist}, 
   pos = {0, -First[i]} - {0.06, 0}]; AppendTo[box, pos]; 
  Callout[{0, -First[i]}, First[i], pos, LabelVisibility -> All], {i, 
   list}], Axes -> False, ImageSize -> 600]

enter image description here

Or use DynamicName,DynamicLocation and stretchText here make a custom Callout:

pts = Table[
   DynamicName[Point[{0, -First[list[[i]]]}], 
    TemplateApply["point<*i*>"]], {i, Length[list]}];

textboxs = {};
labels = Table[
   dist = Min[
     RegionDistance[#, {0, -First[list[[i]]]} - {25, 0}] & /@ 
      textboxs];
   If[dist < 5 + 2, pos = {0, -First[list[[i]]]} - {25, 5 + 2 - dist},
     pos = {0, -First[list[[i]]]} - {25, 0}];
   AppendTo[textboxs, Rectangle[pos, pos + {10, 5}]];
   DynamicName[
    stretchText[ToString[First[list[[i]]]], pos - {0, 5/2}, {10, 5}], 
    TemplateApply["label<*i*>"]], {i, Length[list]}];

Graphics[{AbsolutePointSize[8], pts, labels, Arrowheads[0.3], 
  Table[Arrow[{DynamicLocation[TemplateApply["label<*i*>"], 
      Automatic], 
     DynamicLocation[TemplateApply["point<*i*>"], Automatic]}], {i, 
    Length[list]}]}]

enter image description here

$\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.