Skip to main content

graphics - Preventing label crowding in PieChart RadialCallout and RadialCenter


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



Answer



I had the following thought about the question.




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



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



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..)




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.


Comments

Post a Comment

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]
Post a Comment
Read more

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]
Post a Comment
Read more

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],
Post a Comment
Read more