How to make these callout labels not overlap

Question

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
]

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?

Answer 1

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".

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

Answer 2

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
]

---

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
]

Answer 3

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]

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