Message Boards Message Boards

Packing arbitrary shapes with WordCloud

Posted 6 years ago

enter image description here

We can extract information from WordCloud in order to translate a collection of regions so they pack nicely. First I'll create some BoundaryMeshRegions similar to how the glyphs were created by OP:

$letters = Table[BoundaryDiscretizeGraphics[
  Text[Style[c, Italic, FontFamily -> "Times"]], _Text], {c, Alphabet[]}];

n = 30;

BlockRandom[
  glyphs = RandomChoice[$letters, n];
  scales = RandomReal[5, n],
  RandomSeeding -> 1234
];

Plot the word cloud using random orientations:

wc = WordCloud[AssociationThread[glyphs, scales], WordSpacings -> 0,
  WordOrientation -> "Random", RandomSeeding -> 1234]

Notice that the objects aren't quite touching. Luckily when we convert this scene back to a collection of regions, they will seem to be touching. I think this has to do with padding within Inset. Using regions in the beginning rather then just graphics makes it easier to convert the insets into explicit coordinates and avoid padding.

insets = Cases[wc2, _Inset, ?];

insetToReg[mr_, c_, p_, s_] := 
  BoundaryMeshRegion[TransformedRegion[#, 
   TranslationTransform[c - RegionCentroid[BoundingRegion[#]]]], 
    MeshCellStyle -> {1 -> Black, 2 -> RandomColor[Hue[_]]}]& @ RegionResize[mr[[1]], s]

BlockRandom[Show[insetToReg @@@ insets], RandomSeeding -> 1234]

Or if you prefer a region instead of just a visualization:

RegionUnion[insetToReg @@@ insets]

We can do this for polygons too:

BlockRandom[
  polys = 
   Table[BoundaryMeshRegion[#[[FindShortestTour[#][[2]]]], 
       Line[Mod[Range[16], 15, 1]]] &[RandomReal[{0, 1}, {15, 2}]], n];
  scales = RandomReal[{0, 1}, n],
  RandomSeeding -> 1234
  ];
wc = WordCloud[AssociationThread[polys, scales], WordSpacings -> 0, 
   WordOrientation -> "Random", RandomSeeding -> 1234];
BlockRandom[Show[insetToReg @@@ Cases[wc, _Inset, ?]], 
 RandomSeeding -> 1234]

POSTED BY: Greg Hurst
3 Replies

enter image description here - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

POSTED BY: EDITORIAL BOARD
Posted 6 years ago

Hi Chip,

Nice! Are you using version 12? On 11.3.0 for Mac OS X x86 (64-bit) (March 7, 2018) some letters do not discretize

Cases[$letters, _BoundaryDiscretizeGraphics]

{BoundaryDiscretizeGraphics[Text[ Style["h", Italic, FontFamily -> "Times"]], _Text], BoundaryDiscretizeGraphics[Text[ Style["i", Italic, FontFamily -> "Times"]], _Text],
BoundaryDiscretizeGraphics[Text[ Style["j", Italic, FontFamily -> "Times"]], _Text], BoundaryDiscretizeGraphics[Text[ Style["k", Italic, FontFamily -> "Times"]], _Text],
BoundaryDiscretizeGraphics[Text[ Style["y", Italic, FontFamily -> "Times"]], _Text]}

POSTED BY: Rohit Namjoshi
POSTED BY: Henrik Schachner
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract