# How to make these callout labels not overlap

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 overlap of their labels?

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


• This is very nice! Jun 25, 2022 at 10:15

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 =
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 =
Function[{list, length},
Callout[
{0, -#}, #,
Left, LabelVisibility -> All,
] & /@ list
],
{{short, long}, {10, 50}}
];

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


• Hi, thanks for your answer. But all labels should be on left, which is important for me.
– yode
Jun 20, 2022 at 1:57
• @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? Jun 20, 2022 at 2:22
• Yes, I can accept longer leaders.
– yode
Jun 20, 2022 at 2:44
• What is your values?
– yode
Jun 20, 2022 at 4:56
• @yode Added, sorry for the omission. It's just list[[All, 1]] Jun 20, 2022 at 5:08

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