23
$\begingroup$

Is there any way to make a circular heat map in Mathematica?

Thanks for your help!

Here is a toy example for regular heat map. Can anyone help me make it to a circular one?

data1={{9., 1., 6., 7., 6., 3., 1., 3., 10., 2., 2., 5., 2., 5., 3., 
  1.}, {5., 5., 5., 4., 4., 6., 4., 6., 9., 1., 2., 10., 2., 1., 1., 
  6.}, {2., 7., 6., 2., 8., 10., 8., 9., 2., 5., 3., 9., 7., 8., 7., 
  5.}, {6., 6., 2., 1., 8., 2., 8., 3., 8., 5., 5., 4., 6., 2., 3., 
  6.}, {8., 1., 8., 2., 5., 8., 5., 3., 5., 3., 4., 2., 2., 4., 4., 
  1.}, {10., 2., 8., 10., 3., 6., 1., 9., 3., 5., 2., 5., 1., 3., 7., 
  9.}};

ArrayPlot[data1, ColorFunction -> ColorData["LightTerrain"], 
 Frame -> True, 
 FrameTicks -> {{{{1, "r1"}, {2, "r2"}, {3, "r3"}, {4, "r4"}, {5, 
      "r5"}, {6, "r6"}}, None},
   {None, {{1, "c1"}, {2, "c2"}, {3, "c3"}, {4, "c4"}, {5, "c5"}, {6, 
      "c6"}, {7, "c7"}, {8, "c8"}, {9, "c9"}, {10, "c10"}, {11, 
      "c11"}, {12, "c12"}, {13, "c13"}, {14, "c14"}, {15, "c15"}, {16,
       "c16"}}}}, 
 Epilog -> {Text["Sector1", {2, 8}], Text["Sector2", {6, 8}], 
   Text["Sector3", {10, 8}], Text["Sector4", {14, 8}]}, 
 ImagePadding -> {{20, 20}, {20, 80}}, ImageSize -> Large]

enter image description here

I want to make a circular diagram like the following one.

enter image description here

Reference: https://stackoverflow.com/questions/62556246/how-to-plot-the-variant-circular-bar-chart-in-r-with-ggplot

Is it possible to make a one like this?

enter image description here

Thanks a lot!

Improve this question
$\endgroup$
4
  • 3
    $\begingroup$ somewhat related: Pie Chart Annulus generation $\endgroup$
    – kglr
    Commented Mar 25, 2021 at 6:22
  • $\begingroup$ @kglr Hi kglr, is there any way to plot the dendrogram shown in the 1st circular diagram example for illustrating the seven categories? The example looks very neat. I don't know how to make a similar one in Mathematica. Thanks again for your guidance. $\endgroup$
    – Frankie
    Commented Apr 1, 2021 at 16:20
  • $\begingroup$ Hi Frankie. I was afraid that question was coming:) It can be done using a custom ChartElementFunction. I will update my answer if I come up with a clean way to do it. $\endgroup$
    – kglr
    Commented Apr 1, 2021 at 16:28
  • $\begingroup$ @kglr Hi kglr, thank you very much for your quick reply and look forward to your kind help! $\endgroup$
    – Frankie
    Commented Apr 2, 2021 at 15:37

2 Answers 2

Reset to default
30
$\begingroup$

A more flexible approach: Pre-process input data to construct a data set for SectorChart. To inject an angular gap in the chart, we add a last column to input data and assign to it {}& as the ChartElementFunction (so that it is not rendered). The size of the gap is controlled by the second argument of the function preProcessData.

ClearAll[preProcessData, circularLegend, labelingFunction]

preProcessData[data_, gap_: Automatic, clr_: "Rainbow"] := 
  Module[{del = gap /. Automatic -> 1/16, 
   slices = ConstantArray[1/#[[2]], #] & @ Dimensions[data]}, 
  Append[del -> {Null, 0}] /@ 
    MapThread[Thread[# -> Transpose[{##2}]] &, 
     {Rescale[slices, {0, 1}, {0, 1 - del}], Rescale @ data, data}] /. 
   Rule[a_, {b1_, b2_}] :> Style[Labeled[{a, 1}, b2, Tooltip], ColorData[clr] @ b1]]

circularLegend[min_, max_, colorscheme_: "Rainbow"] := 
  AngularGauge[min, {min, max}, ScaleOrigin -> {{Pi/2, 2 Pi}, 1.1}, 
   ScaleRanges -> ({#, .3} & /@ Partition[Subdivide[min, max, 50], 2, 1]),
   "TickSide" -> Left, "LabelSide" -> Left, 
   "TickLength" -> {Scaled[.04], Scaled[0.02]}, 
   TicksStyle -> FontSize -> Scaled[.07], GaugeMarkers -> None, 
   ScaleRangeStyle -> colorscheme, GaugeFrameStyle -> None]

labelingFunction[nrows_, collabels_] := If[#2[[1]] == nrows, 
   Placed[collabels[[#2[[2]]]], {1/2, 1.1}]] &

Examples:

columnlabels = Append[Style["c" <> ToString@#, 14] & /@ 
    Range[Last@Dimensions[data1]], ""];

rowlabels = Style[2010 + #, 16] & /@ Range[First @ Dimensions @ data1];

radialorigin = 4;

gap = 1/16;

SectorChart[preProcessData[data1], 
 SectorOrigin -> {{Pi/2 + gap Pi, "Counterclockwise"}, radialorigin},
 ChartBaseStyle -> Directive[EdgeForm[{Opacity[1], White}]],
 LabelingFunction -> labelingFunction[First@Dimensions@data1, columnlabels], 
 ChartElementFunction -> Append[ConstantArray["Sector", Length@First@data1], {} &], 
 ChartLegends -> Placed[circularLegend[Min@data1, Max@data1], Center], 
 ImageSize -> 700, SectorSpacing -> {0, 0}, 
 Epilog -> {Text[Style["Legend", Black, 16], {0, 0}], 
   MapIndexed[Text[#, {0, radialorigin - 1/2 + #2[[1]]}] &, rowlabels]}]

enter image description here

Use preProcessData[data1, gap, "LightTerrain"] and circularLegend[Min@data1, Max@data1, "LightTerrain"] to get

enter image description here

To have a gap in the positive quadrant, use

SectorChart[preProcessData[data1, 1/4, "LightTerrain"], 
 SectorOrigin -> {{Pi/2, "Counterclockwise"}, radialorigin},
 ChartBaseStyle -> Directive[EdgeForm[{Opacity[1], White}]],
 LabelingFunction -> labelingFunction[First@Dimensions@data1, columnlabels],
 ChartElementFunction -> Append[ConstantArray["Sector", Length@First@data1], {} &], 
 ChartLegends -> Placed[circularLegend[Min@data1, Max@data1,  "LightTerrain"],  Center],
 ImageSize -> 700, SectorSpacing -> {0, 0}, 
Epilog -> {Text[Style["Legend", Black, 16], {0, 0}], 
   MapIndexed[Text[#, Offset[{30, 0}, {0, radialorigin - 1/2 + #2[[1]]}]] &, 
    rowlabels]}]

enter image description here

Using other built-in ChartElementFunctions:

Multicolumn[SectorChart[preProcessData[data1, 1/4], 
    SectorOrigin -> {{Pi/2, "Counterclockwise"}, radialorigin}, 
    ChartBaseStyle -> Directive[EdgeForm[{Opacity[1], White}]], 
    LabelingFunction -> labelingFunction[First@Dimensions@data1, columnlabels], 
    ChartElementFunction -> 
     Append[ConstantArray[
       ChartElementDataFunction[#, "AngularFrequency" -> 50, 
        "RadialAmplitude" -> 0.2], Length@First@data1], {} &], 
    ImageSize -> Medium, SectorSpacing -> {0, 0}, 
    Epilog -> {Text[Style[#, 16], {0, 0}, {-1, -3}], 
      MapIndexed[Text[#, Offset[{30, 0}, {0, radialorigin - 1/2 + #2[[1]]}]] &, 
       rowlabels]}] & /@ 
   {"TriangleWaveSector", "SquareWaveSector", "OscillatingSector", "NoiseSector"}, 2]

enter image description here

Multiple data sets:

SeedRandom[1]
data2 = RandomReal[{25, 100}, {8, Last@Dimensions@data1}];
data3 = RandomInteger[{10, 30}, {4, Last@Dimensions@data1}];

{rowlabels1, rowlabels2, rowlabels3} = Style[2010 + #, 16] & /@ 
  Range[First@Dimensions@#] & /@ {data1, data2, data3};

radialorigin = 4;
radialorigin2 = radialorigin + 1 + First @ Dimensions @ data1;
radialorigin3 = radialorigin2 + 1 + First @ Dimensions @ data2;

radialorigins = {radialorigin,radialorigin2,radialorigin3};

colors = {"LightTerrain", "Rainbow", "SolarColors"};

charts = MapThread[
   SectorChart[preProcessData[#, 1/4, #2], 
     SectorOrigin -> {{Pi/2, "Counterclockwise"}, #3},
     ChartBaseStyle -> Directive[EdgeForm[{Opacity[1], White}]],
     LabelingFunction -> #4,
     ChartElementFunction -> Append[ConstantArray["Sector", Length@First@#], {} &], 
     ImageSize -> 1 -> 15, SectorSpacing -> {0, 0}] &,
   {{data1, data2, data3}, colors, radialorigins,
    {None, None, labelingFunction[First @ Dimensions @ data3, columnlabels]}}];

legends = MapThread[Inset[circularLegend[Min @ #, Max @ #,  #2], 
    {radialorigin + First[Dimensions @ data1]/2, #3 + 
       First[Dimensions @ #]/2}, Center, Scaled[{.12, .12}]] &, 
   {{data1, data2, data3}, colors, radialorigins}];

Combine the three charts using Show and add legends as Epilog:

Show[charts, 
 Epilog -> {legends, 
   MapThread[MapIndexed[Function[{x, y}, Text[x, Offset[{30, 0},
       {0, # - 1/2 + y[[1]]}]]], #2] &,
     {radialorigins, {rowlabels1, rowlabels2, rowlabels3}}],
   MapThread[Text[#2, Offset[{0, 20}, {#, 0}]] &,
     {radialorigins + (Dimensions[#][[1]]/2 & /@ {data1, data2, data3}), 
     Style["group " <> ToString@#, 16] & /@ Range[3]}]}, 
 PlotRange -> All]

enter image description here

ClearAll[barLegendRow]
barLegendRow = BarLegend[{#2, #}, LegendLabel -> #3, LegendLayout -> "Row", 
    LegendMarkerSize -> {250, 30}] &;

barlegends = MapThread[barLegendRow, 
   {MinMax /@ {data1, data2, data3}, colors, 
    Style["group " <> ToString@#, 14] & /@ Range[3]}];

legends2 = MapThread[Inset[#2, 
     {radialorigin + First[Dimensions@data1]/10, #3 + 
       First[Dimensions@#]/2}, {-1, 0}, Scaled[{1, 1}]] &,
   {{data1, data2, data3}, barlegends, radialorigins}];

Show[charts, 
 Epilog -> {legends2, 
   MapThread[MapIndexed[Function[{x, y}, 
       Text[x, Offset[{30, 0}, {0, # - 1/2 + y[[1]]}]]], #2] &, 
     {radialorigins, {rowlabels1, rowlabels2, rowlabels3}}], 
   MapThread[Text[#2, Offset[{0, 20}, {#, 0}]] &, 
     {radialorigins + (Dimensions[#][[1]]/2 & /@ {data1, data2, data3}), 
     Style["group " <> ToString@#, 16] & /@ Range[3]}]}, 
 PlotRange -> All]

enter image description here

ClearAll[histogramLegend]
histogramLegend = SmoothHistogram[Flatten@#, MaxExtraBandwidths -> 0,
    PlotRange -> {MinMax @ #, Automatic}, PlotLabel -> #3, 
    ColorFunction -> Function[{x, y}, ColorData[#2][x]], 
    Filling -> Axis, Axes -> {True, False}, AspectRatio -> 1/8, 
    PlotRangePadding -> Scaled[.02], 
    PlotStyle -> LineOpacity -> 0] &;

histolegends = MapThread[histogramLegend, 
   {{data1, data2, data3}, colors, 
    Style["group " <> ToString @ #, 14] & /@ Range[3]}];

legends3 = MapThread[Inset[#2, {radialorigin + First[Dimensions@data1]/3, #3 + 
       First[Dimensions@#]/2}, Left, Scaled[{.3, .2}]] &, 
   {{data1, data2, data3}, histolegends, radialorigins}];

Show[charts, 
 Epilog -> {legends3, 
   MapThread[MapIndexed[Function[{x, y}, 
       Text[x, Offset[{30, 0}, {0, # - 1/2 + y[[1]]}]]], #2] &, 
    {radialorigins, {rowlabels1, rowlabels2, rowlabels3}}],
   MapThread[Text[#2, Offset[{0, 20}, {#, 0}]] &,
     {radialorigins + (Dimensions[#][[1]]/2 & /@ {data1, data2, data3}), 
     Style["group " <> ToString@#, 16] & /@ Range[3]}]}, 
 PlotRange -> All]

enter image description here

Improve this answer
$\endgroup$
9
  • 11
    $\begingroup$ Impressive work! should be submitted as a ResourceFunction. $\endgroup$
    – sunt05
    Commented Mar 25, 2021 at 22:27
  • 1
    $\begingroup$ @sunt05 I agree. Many of kglr's MSE posts could become fine WFR entries. $\endgroup$
    – Anton Antonov
    Commented Mar 26, 2021 at 6:41
  • $\begingroup$ Thanks for your kind help! Really appreciate! $\endgroup$
    – Frankie
    Commented Mar 26, 2021 at 12:02
  • 1
    $\begingroup$ @sunt05 I agree too. Many of kglr's quick responses are far more useful than the online manual of Mathematica. I really appreciate kglr's contribution to the community! $\endgroup$
    – Frankie
    Commented Mar 26, 2021 at 12:07
  • $\begingroup$ @sunt05, anton, Frankie, thank you for the kind words. This is a great question. A ResourceFunction is a great idea. I will look into it. Given so many moving parts (input data structure with possibly many layers, layout/labeling/legending choices) it looks like a non-trivial task to put together something clean and robust . $\endgroup$
    – kglr
    Commented Mar 26, 2021 at 20:00
16
$\begingroup$

For starters:

ClearAll[styledData]

styledData[data_, sectorlengths_, colorscheme_: "LightTerrain"] := 
  Fold[Function[{x, y}, Insert[#, .1 -> White, y] & /@ x], 
   Map[Tooltip[1, #] -> ColorData[colorscheme][Rescale[#, MinMax@data, {0, 1}]] &, 
    data, {-1}], 1 + Reverse @ Most @ Accumulate @ sectorlengths];

sectorlengths = {3, 4, 5, 4};

styleddata1 = styledData[data1, sectorlengths];

PieChart[MapIndexed[Labeled[#, Rotate[Style[Row[{"row ", #2[[1]]}], 16], -90 Degree], 
    {{1/2, 1/2}, {.5, -1/5}}] &, styleddata1], 
 SectorOrigin -> {Automatic, 5}, 
 ChartElementFunction -> 
   (ChartElementData["Sector"][{Rescale[#[[1]], 
      {-Pi, Pi}, {Pi/2, 2 Pi}], #[[2]]}, ##2] &),
 ChartLegends -> Placed[BarLegend[{ColorData["LightTerrain"], MinMax @ data1}, 
    LegendMarkerSize -> {30, 200}], {.8, .75}], 
 ImageSize -> Large]

enter image description here

Use

ChartLegends -> Placed[BarLegend[{ColorData["LightTerrain"], MinMax@data1}, 
   LegendLayout -> "Row", LegendMarkerSize -> {200, 30}], {.8, .8}]

to get

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ Thank you very much for your kind help and quick reply! I really appreciate your great contribution to the freshman's community! $\endgroup$
    – Frankie
    Commented Mar 26, 2021 at 12:10

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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