Message Boards Message Boards

GROUPS:

Packing arbitrary shapes with WordCloud

Posted 3 months ago
662 Views
|
3 Replies
|
9 Total Likes
|

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]

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 3 months 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]}

Chip, this is very interesting and useful, thanks for sharing! I would like to add that this is not really working with MM11.3; not that it only has problems with e.g. "i" and "j", the scaling itself does not work. Now that I have updated to MM12 everything is fine. It is nice to know that now there is a fast and easy solution to the packing problem, e.g.:

enter image description here

This reminds me to an old post of mine where I exactly had that problem.

Best regards -- Henrik

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