Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

What I want to do is in any way produce a picture that looks like this

enter image description here

Given a set of words, how can I partition a disk into bricks for these words, such that it looks good?

Here is my sucky construction:

  h = 1.3;
  w = 8;
  R = 22.2;

  f[m_] = Abs[Sqrt[R^2 - (R - h*m)^2]];

  Table[
        Table[
             {-f[m], 0} + {n*w, R - h*m} + {w, h} Random[]/10,
        {n, 0, Ceiling[2 f[m]/w]}
  ], {m, 0, Ceiling[2 R/h]}];

  coordinates = Flatten[%, 1];

with a list

  colorlist = {"DarkRainbow", "Rainbow", "Pastel", "Aquamarine", 
     "BrassTones", "BrownCyanTones", "CherryTones", "CoffeeTones", 
     "FuchsiaTones", "GrayTones", "GrayYellowTones", "GreenPinkTones", 
     "PigeonTones", "RedBlueTones", "RustTones", "SiennaTones", 
     "ValentineTones", "AlpineColors", "ArmyColors", "AtlanticColors", 
     "AuroraColors", "AvocadoColors", "BeachColors", "CandyColors", 
     "CMYKColors", "DeepSeaColors", "FallColors", "FruitPunchColors", 
     "IslandColors", "LakeColors", "MintColors", "NeonColors", 
     "PearlColors", "PlumColors", "RoseColors", "SolarColors", 
     "SouthwestColors", "StarryNightColors", "SunsetColors", 
     "ThermometerColors", "WatermelonColors", "RedGreenSplit", 
     "DarkTerrain", "GreenBrownTerrain", "LightTerrain", "SandyTerrain",
      "BlueGreenYellow", "LightTemperatureMap", "TemperatureMap", 
     "BrightBands", "DarkBands"};
  colorlist2 = {colorlist, colorlist, colorlist, colorlist} // Flatten;

such that I can plot it

  Length[coordinates] "Points"
  Length[colorlist2] "Items"

  Graphics[Point[coordinates]]

  Graphics[
   Table[
    {Text[Style[colorlist2[[i]], Small], coordinates[[i]]]},
    {i, 1, Min[Length@colorlist2, Length@coordinates]}]
   ]

enter image description here

enter image description here


Explainations:

  • f[m_] parameterizes the left edge of a cricle, then I generate the coordinates by counting from top to bottom and from left to right until I reach 2R or the bound given by f[m_], respectively.

  • The vectors "{w, h} Random[]/10" are my attempt to make the thing a little more smooth looking. I like it a little shaky.

  • The list of colors is of course just a random example.

and I'm sure it could look better in general.


There are several problems with my approach.

Some of them are optics, for example:

  • The structure is to rigit and depending on the values R, h and w, some patterns emergy, like the bows you see in the pic.

  • This might be a little difficult to resolve completely, but since some words are longer than others, the words tend to lie above each other.

Other problems:

  • I essentially have to match the two lists every time I change the list of words. I mean it's not the end of the world, but it's not too nice.

  • In the end the words are themed and they will make up clusters, don't know if I can be helped with speeding the sorting up though.

  • ...

Also, I'd appreciate a hint how I can read in the strings for the script from a text file, where each line contains one of the words.

share|improve this question
3  
Are you looking to create a word cloud? I'm tempted to mark as duplicate, but I need some clarifications first. –  Szabolcs Mar 9 '12 at 19:06
2  
To read in lines from a file as strings, use Import["file.txt", "Lines"] –  Szabolcs Mar 9 '12 at 19:44
1  
@Szabolcs it's related but he is asking for a different layout algorithm where (a) the words are all in the same point size and (b) layout is sequential from top to bottom in a brick-like offset grid. –  Verbeia Mar 9 '12 at 23:59
    
I adopted the text processing from that thread, so my words are now in colors and ImageCroped (I don't know what this is good for yet). I tried to copy the code from Heike, but it seems to need Mathematica 8 (I use 6). In any case, that's from the middle to the outer bounds, which it not what I'm looking for. I like the idea of tight packing and slightly different fontsizes though, which should optically work out once you use diffeent colors. –  NikolajK Mar 10 '12 at 0:14
    
Yes, that solution is based on image processing and can't be ported to versions earlier than 7. Do you need the words to be in the same order as you specify them? Or any order will do? If you need the words to be in order, then I think a drawing program with a custom shaped text box might be a much better solution than Mathematica. For ordered words, it sounds like we'd end up reimplementing a text reflow algorithm. Do I understand the problem correctly? –  Szabolcs Mar 10 '12 at 14:51

4 Answers 4

up vote 18 down vote accepted

This is far from perfect, but can be easily improved. The method is simple: building up the disk line-by-line by finding enough words of appropriate sizes to fill up each line. There is plenty of room to optimize spacing, but since it already gives a densely packed circle, I leave it as it is for the moment.

Updated code: now it runs much faster as only a minimal amount of image processing is involved.

First, specify style, number of rows and a set of words:

style = {FontFamily -> "Helvetica", 
   FontSize -> 12}; (* list of style specifications for framed words *)
colorStyle = "BlueGreenYellow"; (* color background of bricks *)
margins = 3; (* frame margins for bricks *)
rows = 20; (* number of rows of bricks *)
words = RandomSample[DictionaryLookup[{"Latin", "*"}], 200];

Unfortunatly, to measure the exact length of words, one has to convert them to raster images, as there is no direct font-to-curve conversion is available out of the box, and font vectorization is even slower than simply rasterizing each word. However, thanks to Pillsy's clever shortcut, this part can be made lightning fast too:

getTextLength[texts_List] := 
  With[{data = Rasterize[Column@texts, "Data"]},
   With[{black = {0, 0, 0}}, Cases[data, 
      line : {black, black, __} :> Count[line, black]]][[1 ;; ;; 2]]];

lengths = getTextLength@(Framed[#, FrameMargins -> margins, 
      BaseStyle -> style] & /@ words); (* word lengths in pixels *)
wordHeight = Last@ImageDimensions@Rasterize@
    Framed[First@words, FrameMargins -> margins, 
     BaseStyle -> style];(* word height in pixels - this is assumed to be the same for each word *)
lineHeight = N[2/rows]; (* disk is in the {-1, 1} interval,total height is 2 *)
wordLengths = (#*(lineHeight/wordHeight)) & /@ lengths;
(* convert pixel lengths to coordinate lengths *)

The following two functions help on positioning and finding suitable words, respectively:

(* get width of each line of bricks in the disk *)
getX[y_] := Sqrt[1 - (y - lineHeight/2)^2];
lineWidths = 
  Table[{(getX@y)*2, -getX@y, y - lineHeight/2}, {y, -1 + lineHeight, 
    1, lineHeight}];

(* function to find a word that fits a given width w, and removes word from word & length lists *)
getWord[w_] := Module[{word, length, pos, coord},
   pos = Position[wordLengths, a_ /; a <= w, 1, 1][[1, 1]];(* 
   find a word that fits the given width *)
   word = words[[pos]];
   length = wordLengths[[pos]];
   words = Delete[words, pos];(* remove word from global list *)
   wordLengths = Delete[wordLengths, pos]; (* 
   remove length from global list *)
   {word, length}
   ];

Now iterate through each line of the disk and fill them up with words:

wordCoordinates = 
  Module[{defW, space, x, y, pos, word, length, coord, found = {}, 
      evenly},
     {defW, x, y} = #;
     space = defW;
     While[(* 
      look for words in lexicon until given width is filled up *)
      space > 0 \[And] Min@wordLengths <= space,
      {word, length} = getWord@space;
      AppendTo[found, {word, {x + length/2 + defW - space, y}}];
      space = Max[0, space - length];
      ];
     evenly = 
      Table[{0, {space*i/(Length@found - 1), 0}}, {i, 0, 
        Length@found - 1}];(* shift entries if there is leftover space *)
     found + evenly
     ] & /@ lineWidths;

Put everything together. Note, that choosing an appropriate image size is important:

diskBricks = Graphics[{
   Module[{color = Lighter@ColorData[colorStyle]@RandomReal[]},
      Mouseover[

       Text[
        Framed[First@#, FrameMargins -> margins, 
         BaseStyle -> Prepend[style, FontColor -> Black], 
         Background -> Lighter@color, FrameStyle -> None], Last@#],
       Text[
        Framed[First@#, FrameMargins -> margins, 
         BaseStyle -> Prepend[style, FontColor -> GrayLevel@.9], 
         Background -> Darker@color, FrameStyle -> Black], Last@#]
       ]

      ] & /@ Flatten[wordCoordinates, 1]
   }, Axes -> False, ImageSize -> 500]

Mathematica graphics

share|improve this answer

I don't know if this is worth it as its own answer, because it only really changes one thing from István Zachar's answer, but there's a much faster way to use Rasterize to find the widths of all the text. Rasterize is slow, but it's really not much slower to create a big image than it is to create a small one. Thus, if we can get all the widths out of a single image, we can speed things up hugely.

Fortunately, since we're sticking everything in a frame, this is actually really easy. First, we make a single column with all the framed text, and we rasterize that, and then we pick out the top and bottom of each frame, which will be a black line starting at the beginning of a row of pixels (since Column aligns everything to the left by default). We use Cases to pick these out, and then just take every other length (since the length of the top of the frame and the bottom of the frame is the same.)

getTextSizes[texts : {___String}, style_: Automatic] :=
 With[{data = 
    Rasterize[Column[Framed[#, BaseStyle -> style] & /@ texts], 
     "Data"]},
  With[{black = {0, 0, 0}},
    Cases[data,
     line : {black, black, __} :> Count[line, black]]][[1 ;; ;; 2]]]

Using

someWords = RandomSample[DictionaryLookup[], 100];

I found that getTextSizes[someWords, {FontFamily -> "Helvetica"}] took less 0.1 seconds (using AbsoluteTiming, which is a must since Rasterize apparently calls out to an external program), which doing one call to Rasterize for each word and using ImageDimensions took around 7 seconds.

share|improve this answer
    
Clever, really clever. I don't really understand why a direct font-to-curve conversion does not exist, but apparently, there is no such thing. Maybe in version 9... –  István Zachar Apr 19 '12 at 10:14
    
I hope you don't mind that I included this in my updated solution. The slow rasterization was the ugliest part I couldn't get rid of. –  István Zachar Apr 19 '12 at 13:55
    
@IstvánZachar Please do! –  Pillsy Apr 20 '12 at 21:23

This solution is based on Heike's method for the word cloud question, but I've avoided the newer image processing functions so it should work in version 6.

The packing computation is done with a 2D binary "mask", with the colour image being updated in parallel.

(* create some example data *)
data=Style[Column@#,FontFamily->"Calibri",10]&/@Split[RandomSample[DictionaryLookup[],150],RandomChoice[{1,2}->{True,False}]&];

(* set the spacing between the blocks *)
margin=3;

(* rasterize the data and sort by area *)
rasters = (1/255.) N@Rasterize[Framed[#, FrameStyle->None,Background->Hue[RandomReal[], 0.1, 1]], "Data"] & /@ data;
sizes=Dimensions[#][[{1,2}]]&/@rasters;
{sizes,rasters}=Transpose@Reverse@Sort@Transpose[{sizes,rasters}];

(* estimate the required image size *)
a=Round[0.75Sqrt[Plus@@Times@@@sizes]];
n=2a+1;

(* the potential function determines the overall shape. p=r^2 gives circular packing.*)
potential=Outer[Plus,#,#]&[0.1(N@Range[-a,a]/a)^2];

(* do the packing computation *)
image=ConstantArray[1.,{n,n}];mask=0.;
Do[
dim=2margin+sizes[[j]];tile=ConstantArray[1,dim];
correlation=ListCorrelate[tile,mask+potential,{1,1}];
pos=Position[correlation,Min[correlation]][[1]];
tile=tile[[(1+margin);;-(1+margin),(1+margin);;-(1+margin)]];
mask+=PadRight[tile,{n,n},0,pos-1+margin];
image*=PadRight[rasters[[j]],{n,n,3},1.,Flatten[{pos-1+margin,0}]]
,{j,Length@data}];

(* make a shadow *)
blur=(#/Total[#,-1])&@Outer[Exp[-Plus@##]&,#,#]&[0.01(N@Range[-8,8])^2];
shadow=Clip[mask+1-RotateRight[ListConvolve[blur,mask,{9,9}],{3,3}],{0,1}];

(* combine the image with the shadow and display *)
Graphics[Raster@Reverse[image shadow],ImageSize->n,PlotRangePadding->0,ImagePadding->0]

enter image description here

share|improve this answer

While this is an old thread and I have already posted one answer, this new method is entirely different, much faster and needs less tweaking: why not use the built-in text-justification ability of Mathematica? The result is surprisingly simple and is almost a one-liner:

w = StringSplit@StringTake[ExampleData[{"Text", "OriginOfSpecies"}], 1000];
r = 10; (* number of rows *)
f = 400; (* scaling factor *)
col = "MintColors";

brick[r_, f_, col_] := Column[Pane[TextCell[
       Row[Button[#, Background -> ColorData[col]@RandomReal[], 
           ImageSize -> {Automatic, f/r}] & /@ RandomSample[w, 20]], 
       "Text", TextJustification -> 1], {#, f/r}
       ] & /@ (Sqrt[1 - Range[1./r - 1, 1 - 1/r, 2/r]^2]*f),
   Alignment -> Center, Spacings -> 0];

brick[r, f, col]

Mathematica graphics

The trick is that no option should be passed to Row as that would override the TextCell's justification option.

Some variants (note that if there are only a few words, the linebreaking is a bit clumsy):

c = 3;
Grid@Map[brick[c = c + 2, 300, #] &, {
       {"MintColors", "LightTerrain", "Pastel"},
       {"Aquamarine", "SiennaTones", "IslandColors"}}, {2}]

Mathematica graphics

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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