How to make callouts match the color of their target items?

Question

How to make callouts in a bubble chart in the same style as below? Specifically, I'd like to know how to make the callout stems match their target bubble colors (automatically).

What I've tried:

n=6;
lbls=ResourceFunction["RandomString"][{n, 10}];
BubbleChart[Callout@RandomReal[1,{n,1,3}],
     ChartLabels->Callout[lbls,LeaderSize->{Automatic,90\[Degree],Automatic},CalloutStyle->Automatic]]

An ideal solution would make recreate the stem's shape too (90 degrees with the little dot) and work for other charts/plot types, e.g. BubbleChart3D, BarChart, etc, e.g.

BarChart[<|"a"->1,"b"->2,"c"->5,"d"->3|>,
     ChartLabels->Callout[Automatic,Above,CalloutStyle->66],ChartStyle->66]
BubbleChart3D[RandomReal[1,{n,1,4}],ChartLabels->Callout[lbls]]

Notes:

• The above graphic comes from this old blog post from Netflix

Answer 1

n = 20;
SeedRandom[77];

lbls = ResourceFunction["RandomString"][{n, 10}];
data = RandomReal[1, {n, 3}];

BubbleChart

Use Callout as wrapper on input data:

bubblechart = BubbleChart[MapThread[
      Callout[Style[#, Directive[EdgeForm[]]], #2, Automatic, 
        Appearance -> "Leader", 
        LabelVisibility -> All,
        CalloutMarker -> 
           Arrowheads[{{0, 1}, {Automatic, 0,          
             Graphics[{ Opacity[.5], Disk[Offset[{-5, 0}, {0, 0}], Offset[5]]}]}}], 
        CalloutStyle ->
           {Directive[Thick, CapForm["Butt"], Opacity[.5], #3], Opacity[0]}] &, 
    {data, Style[#, FontSize -> 14] & /@ lbls, ColorData[66] /@ Range[n]}], 
  PerformanceGoal -> "Speed", 
  ChartStyle -> 66, 
  ChartBaseStyle -> Opacity[.5],
  ImageSize -> 600] 

 postProcess = ReplaceAll[ {_Polygon -> {}, 
    Arrow[a_, ___] :> Arrow[a, {0, -.0075}], 
    Text[a_, Offset[o_, b_], c_] :> 
       Text[a /. Rule[FontSize, _] :> Rule[FontSize, Scaled[.025]], 
        Offset[o/3, b], (-Sign@o) /. {0, y : Except[0]} :> y {-1.2, 0.5}]}];

 postProcess @ bubblechart 

Show[postProcess @ bubblechart /. 
   {Offset[5] -> Offset[3], Offset[{-5, 0}, p_] -> Offset[{-3, 0}, p]}, 
  ImageSize -> 400]

Notes: It is important (1) to use a large font size in printer points rather than in scaled size, and (2) to use a large image size in the original chart. Try using FontSize -> Scaled[.02] (instead of FontSize -> 14) and ImageSize -> 300 (instead of ImageSize -> 500) in the code above to see the reason.

BarChart

data2 = data[[;; 10, 1]];
lbls2 = lbls[[;; 10]];

barchart = BarChart[
  MapThread[
    Callout[Style[#, Directive[EdgeForm[]]], #2, Automatic, 
        Appearance -> "Leader", 
        CalloutMarker -> 
           Arrowheads[{{Automatic, 0,                      
             Graphics[{Opacity[.5], Disk[Offset[{-5, 0}, {0, 0}], Offset[5]]}]}}], 
        LeaderSize -> {{Automatic, 90 Degree, 0}, {10, 0 Degree}}, 
        CalloutStyle -> 
           Directive[Thick, CapForm["Butt"], Opacity[.5], #3]] &, 
    {data2, Style[#, FontSize -> Scaled[.02]] & /@ lbls2, ColorData[66] /@ Range[10]}],
  ChartStyle -> 66, 
  ChartBaseStyle -> Opacity[.5],
  ImageSize -> 800, 
  BarSpacing -> - .1]

Show[ReplaceAll[{_Polygon -> {},
     Text[a_, Offset[o_, b_], c_] :> 
        Text[a, Offset[o/4, b], {-Sign[o[[1]]], 0}]}] @ barchart, 
    ImageSize -> 800, ImagePadding -> {{5, 50}, {5, 5}}] 

Show[ReplaceAll[{_Polygon -> {},
      Text[a_, Offset[o_, b_], c_] :> 
       Text[a, Offset[{7, 10}, b], {-1, 1}, {0, 1}]}] @ barchart, 
     ImageSize -> 800, ImagePadding -> {{5, 5}, {5, 90}}]  

BarChart[MapThread[
   Callout[Style[#, Directive[EdgeForm[]]], #2, Automatic, 
      CalloutMarker -> 
          Arrowheads[{{Automatic, 0, 
            Graphics[{Opacity[.5], Disk[Offset[{-5, 0}, {0, 0}], Offset[5]]}]}}], 
      CalloutStyle -> Directive[Thick, CapForm["Butt"], Opacity[.5], #3]] &, 
   {data2, Style[#, FontSize -> Scaled[.02]] & /@ lbls2, ColorData[66] /@ Range[10]}],
   ChartStyle -> 66, 
   ChartBaseStyle -> Opacity[.5],
   ImageSize -> 700, 
   ImagePadding -> {{10, 10}, {10, 100}}, 
   BarSpacing -> - .2] /. 
 {_Polygon -> {} , 
  Text[a_, Offset[o_, b_], c_] :> Text[a, Offset[{0, 25}, b], {-1, 0}, {0, 1}]} 

Answer 2

For BarChart we can get the desired look using a custom ChartElementFunction since label positioning is much easier compared to BubbleChart:

ClearAll[CEF]
CEF[cedf_ : Automatic, o_ : 5] := 
  Module[{bb = 1.05 Charting`ChartStyleInformation["BoundingBox"][[2, 2]]},
  {Opacity[.5], Disk[Offset[{0, o}, {Mean@#[[1]], bb}], Offset[o]], 
   Text[Style[#3[[1]], FontOpacity -> 1, 14], Offset[{0, 3 o}, {Mean@#[[1]], bb}], 
      {-1, 0}, {0, 1}], 
   Thick, CapForm["Butt"], Line[{{Mean@#[[1]], #2}, {Mean@#[[1]], bb}}],
   (cedf /. Automatic -> ChartElementData["Rectangle"])[##]}] &

Examples:

n = 20;
SeedRandom[777];

lbls = ResourceFunction["RandomString"][{n, 10}];
data = RandomReal[1, n];  

Attach labels to data as metadata:

labelrules = Thread[data -> lbls];


BarChart[labelrules,  
  ChartStyle -> "Rainbow",
  ChartBaseStyle -> Directive[EdgeForm[], Opacity[.5]],
  ImageSize -> 600, 
  ImagePadding -> {{50, 10}, {20, 100}},
  BarSpacing -> {.1, 1},
  ChartElementFunction -> CEF[Automatic, 3]] 

An example with multiple datasets:

labelrules2 = Partition[labelrules, 4];
grouplabels = Style["group " <> ToString @ #, 16] & /@ Range[5];

BarChart[labelrules2,  
  ChartStyle -> "Rainbow",
  ChartBaseStyle -> Directive[EdgeForm[], Opacity[.5]],
  ImageSize -> 600, 
  ImagePadding -> {{50, 10}, {20, 100}},
  BarSpacing -> {.1, 1},
  ChartLabels -> {Placed[grouplabels, Axis], None},
  ChartElementFunction -> CEF[Automatic, 3]] 

Answer 3

Automatic placement of labels to avoid overlaps is a difficult task. Instead we can interactively position the labels using a custom ChartElementFunction.

The following ChartElementFunction allows control of label positions using Locators. The position of the label for a bubble is restricted to stay outside the bounding rectangle of the bubble. The label of a bubble is connected to the nearest of the four poles of the bubble. The first argument specifies the radius (in printer points) of the disk at the tip of the connector line. The second argument gives the style of the line and the third argument specifies the edge style of the main bubble and its connected disk.

A few requirements:

1. We need to use BubbleChart with the option PerformanceGoal -> "Speed" and wrap BubbleChart with Deploy to get the Dynamic elements work properly.
2. The labels should be attached to input data as metadata using the form {data1 ->label1, data2 -> label2 ...}.

ClearAll[labeledBubbleWithConnector]
labeledBubbleWithConnector[o_: 5, connectorstyle_: Thick, edgeform_: None] := 
 With[{bubble = First @ Cases[ChartElementData["Bubble"]@##, _Disk, All], 
    center = Mean /@ #, 
    box = TransformedRegion[Rectangle @@ Transpose @ #, 
      ScalingTransform[{1.25, 1.25}, Mean /@ #]], 
    color = Charting`ChartStyleInformation["Color"]}, 
   DynamicModule[{locator = center + 1.2 {bubble[[2, 1]], 0}, 
     label = #3[[1]], value = #2[[-1]], 
     anchors = center + # & /@ 
       Join[Thread[{{1, -1} bubble[[2, 1]], 0}], 
        Thread[{0, {1, -1} bubble[[2, 2]]}]]}, 
    {EdgeForm[edgeform /. Automatic -> Darker[color]], 
     Tooltip[bubble, value],
     Locator[Dynamic[locator, 
        (locator = If[RegionMember[box]@#, 
           RegionNearest[RegionBoundary@box]@#, #]) &], None], 
     Dynamic @ Module[{anchor1 = First @ Nearest[anchors, locator, 1], 
        middle, off = Sign[locator[[1]] - center[[1]]]}, 
       middle = Sequence @@ 
         If[Sign[anchor1[[2]] - center[[2]]] ==  0,
           {{(anchor1[[1]] + locator[[1]])/2, anchor1[[2]]}, 
            {(anchor1[[1]] + locator[[1]])/2, locator[[2]]}},
           {{anchor1[[1]], locator[[2]]}}]; 
       {FontOpacity -> 1, Text[label, Offset[2 o { off, 0}, locator], -{off, 0}], 
        Disk[locator, Offset[o]] ,
        CapForm["Butt"], connectorstyle, 
        Line[{anchor1, middle, Offset[-o {off, 0}, locator]}]}]}]] &

Examples:

dt = Thread[{{1, 1, 1}, {1, 1, 2}, {1, 1, 3}} ->
   (Style[#, 16, Black] & /@ {"aaplvhpmyk", "stuzprmmfp", "abgpfhxuop"})]; 

Deploy @ 
  BubbleChart[{dt}, 
   BubbleScale -> "Diameter", 
   PerformanceGoal -> "Speed", 
   PlotRangeClipping -> False, 
   PlotRange -> {{.5, 1.5}, {.5, 1.5}}, 
   ImageSize -> 600, 
   ImagePadding -> {{83, 83}, {20, 20}}, 
   ChartBaseStyle -> Directive[EdgeForm[], Opacity[.5]], 
   ChartStyle -> {None, "Rainbow"}, 
   ChartElementFunction -> labeledBubbleWithConnector[3]]

n = 20;
SeedRandom[77];

lbls = ResourceFunction["RandomString"][{n, 10}];
data = RandomReal[1, {n, 3}];

BubbleChart[{Thread[data -> (Style[#, 14, Black] & /@ lbls)]}, 
 BubbleScale -> "Diameter", 
 PerformanceGoal -> "Speed", 
 PlotRangeClipping -> False, 
 ImageSize -> 700, 
 ImagePadding -> {{83, 83}, {20, 20}}, 
 ChartBaseStyle -> Directive[EdgeForm[], Opacity[.75]], 
 ChartStyle -> {None, "Rainbow"}, 
 ChartElementFunction -> labeledBubbleWithConnector[3], 
 DisplayFunction -> Deploy]