# Removing labels if they get too crowded on a plot

For some conditions, the number labels on the plot are too crowded. I've been trying to figure out how to remove some of them if they start to get too close to each other or overlap, with no luck. Since this happens for several different numbers of total stages (n), I've been trying to come up with a function that can do this for any n.

Here is the issue I'm describing:

Starting at n=15 stages/steps at these conditions, the numbers get too crowded together. I want to remove a few numbers for n>15to make it look nicer.

Here is the code that plots the equilibrium line, operating line, and stages (short horizontal and vertical lines):

Manipulate[
Module[{yeq, yN1, sol, check1, check2, stage, test, n, steps,
stepping},
yeq[x_] := m1*x;
yN1[x_] := m2*x + 10;

sol = x /. Solve[yeq[x] == yi, x][[1]];
check1 = x /. Solve[yN1[x] == yi, x][[1]];
check2 = x /. Solve[yeq[x] == yN1[x], x][[1]];

stage[1] = x /. Solve[yeq[x] == 10, x][[1]];
Do[stage[i] = x /. Solve[yeq[x] == yN1@stage[i - 1], x][[1]], {i, 2,
100}];
test = Table[stage[n], {n, 1, 50}];

n = 1;
While[test[[n]] < check1 && If[check2 > 0, yeq[check2] > yi, True], n++];

steps =
Flatten[{{test[[#]], yeq@test[[#]]}, {test[[#]],
yN1@test[[#]]}} & /@ Range@n, 1];
stepping = ReplacePart[Join[{{0, 10}}, steps], {2*n + 1, 2} -> yi];

Plot[{yN1[x], yeq[x], yi}, {x, 0, 1.3},
PlotStyle -> {{Thick, Black}, {Thick, Blue}, {Thick, Dashed,
RGBColor[0, 0.7, 0]}}, PlotRange -> {{0, 1.3}, {0, 120}},
Frame -> True, ImageSize -> {550, 425}, AspectRatio -> Full,
Epilog ->
If[Or[yN1[check2] > yi , check2 < 0], {Line@stepping,
Text[Style[#, 16], {stage[#] + 0.025, yeq[stage[#]] - 3}] & /@
Range@n}]]
],
Grid[{
{Control[{{yi, 99, "inlet concentration (ppm)"}, 40, 120, 1,
Appearance -> "Labeled"}], SpanFromLeft},
{Style["slopes:", Bold],
Control[{{m1, 84, "yeq"}, 84, 108,
1, Appearance -> "Labeled", ImageSize -> Small}],
Control[{{m2, 77, "yN+1"}, 50,
300, 1, Appearance -> "Labeled", ImageSize -> Small}]}
}, Alignment -> Left]
]


I tried using Which to delete labels for certain conditions but I'm limited in what I can do with that:

n >= 25, Delete[Range@n, {-#} & /@ {2, 3, 4, 6, 7, 9, 11, 13, 15}]


I'd like to have a function that deletes a label if the distance between two y-points is lower than some threshold value.

### Update

I have added some additional logic to the ListPlot Callouts to allow to skip a few when the y-distances drop below a certain minimum distance. These can be adjusted to suit your font size. You could also add these variables to your Manipulate and adjust them on the fly.

Image has been updated to show that it is skipping one Callout once the y-distance drops below 5.

You could let Mathematica do the work for you by removing the Epilog from Plot and using a ListPlot of stepping with Callouts for the labeled positions. These two plots could be combined with Show.

Show@{
Plot[
... (* Everything except the Epilog option*)
],
ListPlot[
Evaluate[
Module[{minDistance = 5, numToSkip = 1, skipped = 0},
MapIndexed[
If[
Mod[First@#2, 2] == 0,
If[
Subtract @@ stepping[[First@#2 + {1, 0}, 2]] > minDistance,
Callout[#1, Style[First@#2/2, FontSize -> 10]],
skipped++;
If[
Mod[skipped, numToSkip + 1] == 0,
Callout[#1, Style[First@#2/2, FontSize -> 10]],
#1
]
],
#1
] &]@stepping
]],
Joined -> True, PlotStyle -> Directive[Thin, Black]]
}


Mathematica will automatically arrange the Callouts in the ListPlot to prevent collision. There are a few options to customise the callout. For example you can make the callout line shorter or remove it altogether.

Hope this helps.

• This is an interesting solution, the only problem is when I make the font size bigger, the text still overlaps. Apr 14, 2017 at 16:28
• @baumannr See update. Apr 20, 2017 at 21:08