# How to construct a treemap using non-rectangles?

I've written the standard version of a tree map (a graphic that shows nested data) and I'm looking to improve on this layout by switching to different types of polygons or perhaps circles. Can anyone see a way to adapt this code in the style of a Voronoi diagram or otherwise?  Here is the code:

$buf = .05;$3Dbuf = .1; $3DQ = True; ToList[x_List] := x; ToList[x_] := {x}; FlatJoin[list___] := Join @@ (ToList /@ {list}); Second[x_] := x[];$frameStyle = Sequence[EdgeForm[Directive[Opacity[0.6], Black, Thin]], GrayLevel[.7], Opacity[.1]];
$leafStyle = Sequence[EdgeForm[Directive[Black, Thin]], GrayLevel, Opacity]; drawRectangle[{p1_, p2_}, area_List, max_, depth_] /; Length[area] > 1 := {{$frameStyle,
If[$3DQ, Cuboid[Append[p1, depth], Append[p2, depth]], Rectangle[p1, p2]]}, {First @ TreeMap[area, (1-$buf)p1 + $buf p2, (1-$buf)p2 + $buf p1, max, depth +$3Dbuf]}};

drawRectangle[{p1_, p2_}, _, max_, depth_] := {$leafStyle, If[$3DQ, Cuboid[Append[p1, depth], Append[p2, depth]], Rectangle[p1, p2]]};

TreeMap[areas2_, lowerLeft2_, upperRight_, max_, depth_:0] := Module[
{
width, height, area, aspectRatio, fixedLengthDirection,
fittedAreas, i, j, varLength, fixedLength, incs, last,
aspectRatios, incsPts, lowers, uppers, layout, vl, recs,
prims, lowerLeft, areas, areas1
},

prims = {};
areas1 = areas2 / Total[areas2, {1, Infinity}] * Apply[Times, upperRight - lowerLeft2];
areas = Total[areas1, {2,Infinity}];
lowerLeft = lowerLeft2;
For[j = 1, j <= Length[areas], Null,

{width, height} = Subtract[upperRight, lowerLeft];
area = width * height;
aspectRatio = width / height;

If[aspectRatio < 1,
fixedLength = width;
fixedLengthDirection = "Horizontal",
fixedLength = height;
fixedLengthDirection = "Vertical"
];

If[j == Length[areas],
AppendTo[prims,  drawRectangle[{lowerLeft, upperRight}, Last @ areas1, max, depth]]; Break[]];

For[i = j, i <= Length[areas], i++,
fittedAreas = areas[[j;;i]];
varLength = Total[fittedAreas] / fixedLength;
incs = fittedAreas / varLength;
If[i > 1 && Max[varLength / incs] >= max, Break[]];
layout = {varLength, incs, areas1[[j;;i]]};
];
j = i;

If[fixedLengthDirection === "Vertical",
incsPts = FlatJoin[Second[lowerLeft], Second[lowerLeft] + Accumulate[layout[]]];
uppers = Thread[{First[lowerLeft] + layout[], Rest[incsPts]}];
recs = Transpose[{lowers, uppers}]
,
incsPts = FlatJoin[First[lowerLeft], First[lowerLeft] + Accumulate[layout[]]];
uppers = Thread[{Rest[incsPts], Second[lowerLeft] + layout[]}];
recs = Transpose[{lowers, uppers}]
];

drawRectangle[##, max, depth]&, {recs, layout[]}]];
lowerLeft = If[fixedLengthDirection === "Vertical",
{First[lowerLeft] + layout[], Second @ lowerLeft},
{First @ lowerLeft, Second[lowerLeft] + layout[]}
];
];

If[$3DQ, Graphics3D[#, Boxed -> False, Background -> Black]&, Graphics][{prims}] ];  • I'm glad you weren't disheartened by the reception and closure (and deletion) of your previous post on treemaps, and made an effort on the code (actually, a working implementation) — a hearty +1 for that! I wish more new users were like this :) – rm -rf Jun 3 '12 at 6:13 • Thanks @R.M. I found a good explanation of basic algorithm here: win.tue.nl/~vanwijk/stm.pdf – M.R. Jun 3 '12 at 6:18 • FlatJoin seems like a strange function; could you not write FlatJoin[list___] := Flatten[{list}, 1]? – Mr.Wizard Jun 3 '12 at 6:31 • Yes, that is much better, thanks. – M.R. Jun 3 '12 at 6:40 • You could try using RLink as there are some nice Treemap plotting packages in R. There is some R code here you could implement (if you have Windows mathematica.stackexchange.com/questions/15373/…): stat.auckland.ac.nz/~paul/Reports/VoronoiTreemap/… – Jonathan Shock Mar 20 '13 at 5:27 ## 1 Answer It's not a TreeMap using non-rectangles. But maybe can inspire someone to go beyond. I believe that I get a nice squarification using this article suggested by @M.R. The code is for Mathematica V10, and can be tested in the WolframCloud. I played with Associations and some others new MMA funcitons as Area and the new @* notation. (*Test Function*)$testArea=Normalize[Reverse@Sort@RandomReal[300,10],N@*Total];
drawRec[rec_List]:=Graphics[{EdgeForm[Thin],RandomColor[RGBColor[_,1,NormalDistribution[.1,.1]]],Tooltip[Rectangle@@#,RandomInteger]}&/@rec]

(*Create Frame*)
createFrame[ass_Association]:=createFrame[ass["orgFrame"],ass["areas"]]
createFrame[orgFrame:{{orgX1_,orgY1_},{orgX2_,orgY2_}},area_List]:=
Module[{orgX=Abs[orgX2-orgX1],orgY=Abs[orgY2-orgY1],totalArea=N@Total@area,newX,newY,nextFrame,hForm,worstDiv,worstX,worstY},

(*discovery original frame form*)
hForm=If[orgX>orgY,True,False];

(*calculate new frame dimensions, based on informed areas*)
If[hForm
,newY=orgY;newX=totalArea/orgY
,newX=orgX;newY=totalArea/orgX
];

(*calculate worst area dimensions*)
If[hForm
,worstX=newX;worstY=Last@area/newX;
,worstY=newY;worstX=Last@area/newY
];

(*return data*)
<|
"orgFrame"-> orgFrame
,"newFrame"-> {{orgX1,orgY1},{orgX1,orgY1}+{newX,newY}}
,"nextFrame"-> {{orgX1,orgY1}+If[hForm,{newX,0},{0,newY}],{orgX2,orgY2}}
,"areas"->area
,"worstDivRatio"-> Abs[worstX-worstY]
|>
]
(*t=createFrame[{{0,0},{1.5,1/1.5}},$testArea]*) (*Find Best Section Partition*) findBestSector[orgFrame_List,orgArea_List]/;Length@orgArea==1:=createFrame[orgFrame,orgArea] findBestSector[orgFrame_List,orgArea_List]/;Length@orgArea>=2:=Module[{r={},i,f1,f2,nextArea}, For[i=1,i<Length@orgArea,i++, f1=createFrame[orgFrame,orgArea[[;;i]]]; f2=createFrame[orgFrame,orgArea[[;;i+1]]]; If[f2["worstDivRatio"]>f1["worstDivRatio"],r=f1;Break[]]; r=f2; ]; r["nextArea"]=orgArea[[i+1;;-1]]; r ] (*findBestSector[{{0,0},{1.5,1/1.5}},$testArea]*)

(*Find All Sectors*)
findSectors[frameData_Association]:=Module[{r},
r=findBestSector[frameData["orgFrame"],frameData["areas"]];
If[Not@KeyExistsQ[r,"nextArea"]||r["nextArea"]==={}
,r
,Flatten@{r,findSectors[<|"orgFrame"->r["nextFrame"],"areas" -> r["nextArea"]|>]}
]
]

(*r=findSectors[\[LeftAssociation]"orgFrame"\[Rule]{{0,0},{1.5,1/1.5}},"areas"\[Rule]$testArea\[RightAssociation]];*) (*drawRec[r\[LeftDoubleBracket]All,"newFrame"\[RightDoubleBracket]]*) (*Filling Sector with Squares*) fillSector[ass_Association]:=fillSector[{ass["orgFrame"],ass["areas"]}] fillSector[{{{orgX1_,orgY1_},{orgX2_,orgY2_}},areas_List}]:= Module[{orgX=Abs[orgX2-orgX1],orgY=Abs[orgY2-orgY1],hForm,frameBase}, (*discovery original frame form*) If[orgX>orgY ,frameBase={{#1,0},{#2,orgY}}&@@@Partition[Accumulate@Prepend[areas/orgY,0],2,1] ,frameBase={{0,#1},{orgX,#2}}&@@@Partition[Accumulate@Prepend[areas/orgX,0],2,1] ]; Map[#+{orgX1,orgY1}&,frameBase,{-2}] ] (*r=findSectors[\[LeftAssociation]"orgFrame"\[Rule]{{0,0},{1.5,1/1.5}},"areas"\[Rule]$testArea\[RightAssociation]];*)
(*fFrame=fillSector[{r\[LeftDoubleBracket]1,"newFrame"\[RightDoubleBracket],r\[LeftDoubleBracket]1,"areas"\[RightDoubleBracket]}]*)
(*drawRec@fFrame*)

(*treeMapPlot!*)
treeMapPlot[areas_List,frame:{{x1_,y1_},{x2_,y2_}}:{{0,0},{N@GoldenRatio,1}}]:=Module[{r,frameArea},
frameArea=Area@*Rectangle@@frame;
r=findSectors[<|"orgFrame"->frame,"areas"->frameArea*Normalize[Reverse@Sort@areas,Total]|>];
r=Flatten[fillSector/@Values@r[[All,{"newFrame","areas"}]],1];
Graphics[{EdgeForm[Thin],RandomColor[RGBColor[_,1,NormalDistribution[.1,.1]]],Rectangle@@#}&/@r]
]
area=RandomReal[1,100];
treeMapPlot[area]


This is an example with 100 squares. This other has 10k squares. Possible improvements are: Labels, Tooltips, Color Control and Depth Options.