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

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more