13
$\begingroup$

Is it possible to avoid this unreadable situation with label crowding when using PieChart's RadialCallout and RadialCenter methods?

PieChart[tabData109[[All, 2]], 
 SectorOrigin -> {{Pi/2, "Clockwise"}, 1}, 
 ChartStyle -> tabData109[[All, 1]] /. PACE["TAB_COLOR_RULES"],
 LabelingFunction -> (Placed[
     Row[{NumberForm[
        100 # /Plus @@ tabData109[[All, 2]] // N, {3, 1}], "%"}], 
     "RadialCenter"] &),
 ChartLabels -> 
  Placed[tabData109[[All, 1]] /. PACE["TAB_DESCRIPTION_RULES"], 
   "RadialCallout"]]

Gives:

enter image description here

$\endgroup$
4
  • $\begingroup$ Well maybe it's LabelingFunction what you are looking for. $\endgroup$
    – Silvia
    Aug 2 '12 at 20:29
  • $\begingroup$ OK now I think it might not be possible to avoid crowding near some TOO narrow sectors (eg. those percentages for the right above white sectors). So maybe you will have to put them outside, increasing radials of some labels? $\endgroup$
    – Silvia
    Aug 2 '12 at 21:03
  • $\begingroup$ It seems not so easy for me.. My basic idea is to rearrange the labels in the chart after having been generated by PieChart. So at least placement of each label is needed. Haven't figured out how to get them efficiently. And I have to say the underlying expression of the chart doesn't looks friendly enough.. $\endgroup$
    – Silvia
    Aug 3 '12 at 9:34
  • $\begingroup$ Couldnt you just ROTATE the Lables according to the angle of their respective pie? I would love to know how to do that. $\endgroup$
    – Tino
    Nov 15 '19 at 12:55
14
$\begingroup$

I had the following thought about the question.

Part 1

We generate some random crowded test data first:

data = RandomChoice[{20, 15, 8, 7, 6, 5} -> {1, 2, 3, 4, 5, 10}, 50]

{1, 4, 1, 3, 1, 2, 2, 3, 5, 2, 1, 1, 1, 1, 3, 5, 4, 5, 2, 1, 2, 1, 1, 2, 5, 1, 1, 3, 1, 1, 3, 3, 2, 5, 2, 2, 2, 1, 4, 4, 1, 2, 1, 4, 2, 3, 1, 1, 5, 4}

dataLength = Length[data]; 

descriptionData = (FromCharacterCode[RandomInteger[{97, 122}, 
        {RandomInteger[{4, 10}]}]] & ) /@ data

Mathematica graphics

valueData = (NumberForm[#1, {3, 1}] & ) /@ N[(100*data)/Total[data]]; 

labelLst = MapThread[Row[{#1, ":  ", #2, "%"}] & , {descriptionData, valueData}]

Mathematica graphics

Then draw the PieChart using system function:

chartgraph = PieChart[data,
  SectorOrigin -> {{\[Pi]/2, "Clockwise"}, 1},
  LabelingFunction -> (Placed[
      Framed[Style[
        labelLst[[#2[[2]]]],
        Bold, 13],
       Background -> Lighter[Purple, 0.95]],
      "RadialCallout"] &),
  ChartStyle -> EdgeForm[{White, Opacity[0.2]}],
  PlotRange -> All]

Mathematica graphics

Part 2

Now we'll do some dirty job, modify the underlying data of chartgraph.

First define some functions which are not aesthetic at all, and are very likely not so general for any PieChart. (Their function is adjusting the radial of "RadialCallout" lines.)

Clear[extentFunc]
extentFunc[labeldata_, Radial_] :=
 ReplaceAll[labeldata,
  {{{}, {}}, {{{}, {}},
     {directive1__?(Head[#] =!= LineBox &),
      LineBox[{r0_, R0_}],
      LineBox[{R0_, endpoint_}]},
     {directive2__?(Head[#] =!= LineBox &),
      DiskBox[r0_, diskR_]},
     InsetBox[labeltext_, labPos_, labOPos_]}} :>
   With[{R = Radial/Norm[R0] R0},
    With[{v = R - R0},
     horizonLineLength = Abs[(endpoint - R0)[[1]]];
     {{{}, {}}, {{{}, {}},
       {directive1,
        LineBox[{r0, R}],
        LineBox[{R, endpoint + v}]},
       {directive2, DiskBox[r0, diskR]},
       InsetBox[labeltext, labPos + v, labOPos]}}
     ]]]

Clear[chartExtentFunc]
chartExtentFunc[chartgraph_, Radial_?NumericQ] :=
 ToExpression[ReplacePart[
   ToBoxes[chartgraph],
   {1, 3, 2, 2, 1, 1, 1} -> (
     ReplacePart[#,
        1 -> extentFunc[#[[1]], Radial]
        ] & /@
      ToBoxes[chartgraph][[1, 3, 2, 2, 1, 1, 1]]
     )]]

chartExtentFunc[chartgraph_, Radial_List] :=
 ToExpression[
  With[{num = $ModuleNumber},
    StringReplace[ToString[
      ReplacePart[
       ToBoxes[chartgraph],
       {1, 3, 2, 2, 1, 1, 1} -> (
         MapThread[
          ReplacePart[#1, 1 -> extentFunc[#1[[1]], #2]] &,
          {ToBoxes[chartgraph][[1, 3, 2, 2, 1, 1, 1]],
           Radial}]
         )],
      InputForm],
     "DynamicChart`click$" ~~ (a : DigitCharacter ..) ~~ 
       "$" ~~ (b : DigitCharacter ..) :>
      "DynamicChart`click$" <> a <> "$" <> ToString[num]
     ]] // ToExpression]

Now try them on our chartgraph with random radials:

chartExtentFunc[chartgraph,RandomReal[{2.1, 3},dataLength]]/.Thickness[a_]:>Thickness[.5 a]

Mathematica graphics

It is of course nice to associate radials with correspond polar angles:

\[Theta]Set = \[Pi]/2 - (Accumulate[#] - 1/2 #) &[
data/Total[data] 2 \[Pi]] // N;

2 + If[0 <= # < \[Pi]/8 || \[Pi] - \[Pi]/8 < # < \[Pi] + \[Pi]/8 || 
  2 \[Pi] - \[Pi]/8 < # <= 2 \[Pi], 2.1 Abs[Cos[#]]^12, .3/
 Abs[Sin[#]]] & /@ (\[Pi]/2 - \[Theta]Set);

chartExtentFunc[chartgraph, %]

Mathematica graphics

MapIndexed[
  Piecewise[{{2.4, # == 0}, {3.4, # == 1}, {4.4, # == 2}}] &[
Mod[#2[[1]], 3]] &, (\[Pi]/2 - \[Theta]Set)];

chartExtentFunc[chartgraph, %] /. Thickness[_] :> Thickness[0]

Mathematica graphics

Part 3

Well the above results are not so nice. So we try to improve it by introducing an optimization function (potential function).

RvariableSet = Table[Symbol["R" <> ToString[i]], {i, dataLength}]

Clear[centerPos]
centerPos[k_] := 
 R[[k]] {Cos[\[Theta][[k]]], Sin[\[Theta][[k]]]} + {L, 0} + {W/2, 0}

Clear[centerPotentialFunc]
centerPotentialFunc[k_, Rmin_, Rmax_] := 
 Exp[-10 (R[[k]] - Rmin)] + Exp[10 (R[[k]] - Rmax)]

Clear[interactionPotentialFunc]
interactionPotentialFunc[i_, j_] := If[i == j, 0,
  With[{d = Sqrt[#.#]/Sqrt[W^2 + H^2] &[centerPos[i] - centerPos[j]]},
   2 Exp[-10 (d - 1.1)]
   ]]

(Here W and H are the max width and height of the label text box separately.)

potentialExpr = 
  Block[{\[Theta] = \[Theta]Set, L = horizonLineLength, W = 1.3, 
H = 0.25, R = RvariableSet},
   Sum[centerPotentialFunc[i, 2.2, 5], {i, 1, dataLength}] + 
Sum[interactionPotentialFunc[i, j], {i, 1, dataLength},
   {j, 1, dataLength}]];

(Here for each i, the upper and lower bound of j can be localized to neighborhood of it to reduce the size of potentialExpr.)

Grad of the total potential (I thinks here I "inject" RvariableSet in an unidiomatic way?):

gradExpr = Module[{CompileTemp},
   CompileTemp[RvariableSet, Evaluate[
      D[potentialExpr, #] & /@ RvariableSet
      ]] /. CompileTemp -> Compile];

Run the kinetics simulation for 300 steps:

initRSet = ConstantArray[3, dataLength];

dt = 1 10^-3;

RSetSet = NestList[Function[paras, Module[{a, v},
     v = paras[[2]];
     a = -gradExpr @@ paras[[1]];
     v = v + 1/2 dt a;
     (If[#[[1]] < 
       2.1, {2.1, -#[[2]]}, {#[[
        1]], .1 #[[2]]}] & /@ ({paras[[1]] + dt v, 
       v}\[Transpose]))\[Transpose]
     ]], {initRSet, ConstantArray[0, dataLength]}, 300];

Manipulate[
 ListPolarPlot[{\[Theta]Set, RSetSet[[k, 1]]}\[Transpose], 
  PlotStyle -> Purple, Joined -> True, 
  Epilog -> {Circle[{0, 0}, 2.1], Circle[{0, 0}, 2]}, PlotRange -> All],
 {k, 1, Length[RSetSet], 1}]

Mathematica graphics

Now try the result on chartgraph:

chartExtentFunc[chartgraph, RSetSet[[-1, 1]]]/.Thickness[a_]:>Thickness[.5 a]

Mathematica graphics

% /. FrameBox[expr_, opt__] :> expr /. Bold -> Plain

Mathematica graphics

So it's kind of better now. (Though still not good enough..)

Conclusion

Thus far, it seems if I choose a proper potential function, I will get a good result. But the final results are not as satisfying as I want. I think there can be more essential improvements, for efficiently and for better result.

$\endgroup$
4
  • 1
    $\begingroup$ No doubt about it, this is a very good answer. Still, I can't help thinking that, if you find yourself in such a pathological situation, it might be worth reconsidering whether a pie chart is really the best way to present the data. $\endgroup$ Aug 4 '12 at 3:57
  • $\begingroup$ @OleksandrR. yes totally agree with you about reconsidering a best way to present the data. On the other hand, I just feel fun to draw those iris like charts, they induced me and made me wondering :) Anyway, kind of sharing it for pretty generated pictures :) $\endgroup$
    – Silvia
    Aug 4 '12 at 4:09
  • $\begingroup$ Thanks for all the nice work Silvia. I've also forwarded this page to WRI's tech team for consideration. $\endgroup$ Aug 10 '12 at 2:46
  • $\begingroup$ @alancalvitti Thanks. I believe they have nicer solutions. (such as the algorithm used in "SpringElectricalEmbedding" layout for GraphPlot) $\endgroup$
    – Silvia
    Aug 12 '12 at 7:59
9
$\begingroup$

For moderately crowded cases like yours there is a very simple solution. Because I do not have your data, I will use a modified example from Documentation. There is a typical problem of crowded labels in the Image 1. And it is fixed on the Image 2 by using SectorOrigin option to adjust angular positions of labels so to distribute them properly. You basically should shift location of most dense label areas from "north" and "south" to "east" and "west".

Image 1 - crowded labels

enter image description here

Image 2 - correction by rotation via SectorOrigin option

enter image description here

The code

Manipulate[

 elem = SortBy[
   Tally[Flatten[
     Table[ElementData[z, "DiscoveryCountries"], {z, 1, 108}]]], Last];

 Column[{

   PieChart[
    Apply[Labeled[#1, #2, "RadialCallout"] &, 
     Transpose[{N[(elem[[All, 2]]/Total[elem[[All, 2]]])], 
       elem[[All, 1]]}], 2],  
    LabelingFunction -> (Placed[
        Row[{NumberForm[100 #, 2], "%"}, "\[MediumSpace]"], 
        Tooltip] &), ChartStyle -> "LightTerrain", PlotRange -> All, 
    PlotLabel -> Style["RadialCallout", Bold, 16], ImageSize -> 320, 
    SectorOrigin -> k],

   PieChart[
    Apply[Labeled[#1, #2, "VerticalCallout"] &, 
     Transpose[{N[(elem[[All, 2]]/Total[elem[[All, 2]]])], 
       elem[[All, 1]]}], 2],  
    LabelingFunction -> (Placed[
        Row[{NumberForm[100 #, 2], "%"}, "\[MediumSpace]"], 
        Tooltip] &), ChartStyle -> "LightTerrain", PlotRange -> All, 
    PlotLabel -> Style["VerticalCallout", Bold, 16], ImageSize -> 340,
     SectorOrigin -> k]

   }]

 , {{k, 1.3, "rotate"}, 0, 2 Pi, Appearance -> "Labeled"}, 
 FrameMargins -> 0]
$\endgroup$
3
  • $\begingroup$ Rotation is indeed a good idea. But how about it's crowded everywhere? $\endgroup$
    – Silvia
    Aug 4 '12 at 0:26
  • $\begingroup$ @Silvia Thanks! I think introducing label whiskers of alternating lengths would help a completely overcrowded labels. But this needs more work. $\endgroup$ Aug 4 '12 at 5:52
  • $\begingroup$ @VitaliyKaurov, +1 but even on the simple dataset shown above, no angular value of SectorOrigin can prevent all overlaps. I think a general problem with intelligent label layout is there's no easy (or any) way to retrieve text bounding boxes. Do you know of a way? $\endgroup$ Sep 6 '12 at 22:12
6
$\begingroup$

In 11.1, Callout support was added to PieChart. This does something similar to Silvia's second example in part 2 of her answer. Using her data

data = RandomChoice[{20, 15, 8, 7, 6, 5} -> {1, 2, 3, 4, 5, 10}, 50];
dataLength = Length[data];
descriptionData = 
 (FromCharacterCode[RandomInteger[{97, 122}, {RandomInteger[{4, 10}]}]] &) /@ data;
valueData = (NumberForm[#1, {3, 1}] &) /@ N[(100*data)/Total[data]];
labelLst = MapThread[Row[{#1, ":  ", #2, "%"}] &, {descriptionData, valueData}];

it is fairly simple to set up

PieChart[data, SectorOrigin -> {{\[Pi]/2, "Clockwise"}, 1},
 ChartLabels -> Callout[Style[#, 14] & /@ labelLst], 
 ChartStyle -> EdgeForm[{White, Opacity[0.2]}], PlotRange -> All]

enter image description here

Two things of note: 1) I had to expand the size of the image to avoid overlap, and 2) I clicked on a couple of the pie pieces to demonstrate what that looks like in this scheme.

$\endgroup$
2

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.