Duplicated points not labeled when presented to ListPlot as point->"label"

Question

A minimal working example is given via:

{{{1, 4} -> "A"}, {{2, 2} -> "B"}, {{3, 1} -> "C"}, {{3, 7} ->   "D"}, {{4, 5} -> "E"}, {{4, 5} -> "F"}, {{5, 3} -> "G"}, {{6, 6} ->
    "H"}}
ListPlot[%]

As can be seen, "E" and "F" have not been labeled. I am happy about a general solution but also a fix-around for this specific problem would be great.

Answer 1

This solution will Merge duplicate keys by joining their Value strings using "," as a separator.

data = {{{1, 4} -> "A"}, {{2, 2} -> "B"}, {{3, 1} -> "C"}, {{3, 7} -> 
    "D"}, {{4, 5} -> "E"}, {{4, 5} -> "F"}, {{5, 3} -> 
    "G"}, {{6, 6} -> "H"}}

data // Flatten // GatherBy[#, First] & // 
    Merge[StringJoin@StringRiffle[#, ","] &] // Normal // 
  List /@ # & // ListPlot

Answer 2

Is this acceptable as a work-around?

list = {{{1, 4} -> "A"}, {{2, 2} -> "B"}, {{3, 1} -> "C"}, {{3, 7} -> 
     "D"}, {Callout[Callout[{4, 5}, "E", Right], "F", 
     Left]}, {{5, 3} -> "G"}, {{6, 6} -> "H"}};
ListPlot[list, PlotRange -> All]

Answer 3

Here is a procedure to achieve your aim: First we gather all parts with the same position:

(old = Select[GatherBy[lab, (#[[1, 1]]) &], Length[#] > 1 &])

Then we join the labels for points with equal positions:

new = ({#[[1, 1, 1]] -> ToString[Join[#[[All, 1, 2]]]]}) & /@ (old = 
     Select[GatherBy[lab, (#[[1, 1]]) &], Length[#] > 1 &]);

Then we replace the parts with equal positions by the joined labels:

lab = Join[DeleteElements[lab, Flatten[old, 1]], new];

All together:

lab = {{{1, 4} -> "A"}, {{2, 2} -> "B"}, {{3, 1} -> "C"}, {{3, 7} -> 
     "D"}, {{4, 5} -> "E"}, {{4, 5} -> "F"}, {{5, 3} -> 
     "G"}, {{6, 6} -> "H"}};
new = ({#[[1, 1, 1]] -> ToString[Join[#[[All, 1, 2]]]]}) & /@ (old = 
     Select[GatherBy[lab, (#[[1, 1]]) &], Length[#] > 1 &]);
lab = Join[DeleteElements[lab, Flatten[old, 1]], new];
ListPlot[lab]