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.

How can I wrap text around a circle?

For example: the text in the sectors of this chord plot.

Perhaps one could use FilledCurve[] and then apply a GeometricTransformation[]?

share|improve this question
    
Would a fixed-width font be acceptable? –  Mr.Wizard May 18 '12 at 14:44
    
Yes, assume courier. –  M.R. May 18 '12 at 14:57

5 Answers 5

up vote 17 down vote accepted

The following response borrows shamelessly from Mr.Wizard:

Manipulate[
  Graphics[{{Dashed, If[circle, Circle[{0, 0}, r], {}]},
  Rotate[MapThread[
      Rotate[Text[Style[#, FontFamily -> "Courier", fs], #2], 
      90° - #3] &, {txt, {-r Cos[#], r Sin[#]} & /@ (range =
      Range[0, arc, arc/(Length@txt - 1)]), range}], θ, {0,
      0}]},
  ContentSelectable -> True,
  PlotRange -> 3,
  PlotRangePadding -> .5,
  ImageSize -> {500, 400}, Axes -> axes],
  {{fs, 20, "font size"}, 5, 50, Appearance -> "Labeled"},
  {{r, 2, "radius"}, 0.1, 3, Appearance -> "Labeled"},
  {{arc, 2.5, "arc length"}, 0, 2 π, Appearance -> "Labeled"},
  {{θ, 0, "location on arc"}, 0, 2 π},
  {{circle, True}, {True, False}},
  {{axes, True}, {True, False}},
  Initialization :> {txt = "This is some text to wrap" // Characters;}
]

curved text

Note: "Arc length" is based on the unit circle. $2 \pi$, or approximately 6.28 corresponds to a $360^\circ$ arc on the unit circle. The actual full arc length will be $2\pi r$.

share|improve this answer
1  
Nice extension! (I wish we had a collaboration feature as this really should replace my answer, yet both of us deserve some credit.) –  Mr.Wizard May 18 '12 at 16:32
    
Thanks. I was going to post my code in a comment under your response but I wanted to include a screen shot. You deserve most of the credit for having the key insights. –  David Carraher May 18 '12 at 16:51

This places a string on the outside of a unit circle. It works for variable width fonts.

circularText[str_, ang : {a0_, a1_} : {0, 2 Pi}, scale:(_?NumericQ): 1] := 
 Module[{text, curves, pts, xrange, ymin, xrlst, subgroups, maxwidth, centers},
  (* transform string to FilledCurves *)
  text = ImportString[
     ExportString[Style[str, Bold, FontFamily -> "Helvetica", FontSize -> 12], "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {curves, pts} = 
   Flatten[Cases[text, FilledCurve[a_, b_] :> {a, b}, 
     Infinity], {{2}, {1, 3}}];

  (* Find coordinate range for each character *)
  xrlst = {Min[#1], Max[#1]} & /@ pts[[All, All, 1]];
  xrange = {Min[xrlst[[All, 1]]], Max[xrlst[[All, 2]]]};
  ymin = Min[pts[[All, All, 2]]];

  (* collect curves whose xrange overlap. They indicate letters with holes. *)
  subgroups = Gather[Range[Length[xrlst]],
    (IntervalMemberQ[#1, #2] || 
         IntervalMemberQ[#2, #1]) & @@ {Interval[xrlst[[#1]]], 
       Interval[xrlst[[#2]]]} &];
  xrlst = (Interval @@ xrlst[[#]])[[1]] & /@ subgroups;

  (* calculate maximum width of all letters, and centers of each letter *)
  maxwidth = Max[xrlst[[All, 2]] - xrlst[[All, 1]]];
  centers = Mean /@ xrlst;

  (* translate and rescale points *)
  pts = MapIndexed[
    pts[[#1]] /. {a_, b_?NumericQ} :> {a - centers[[#2[[1]]]], b - ymin}/maxwidth/
          Length[subgroups] (a1 - a0) scale + {0, 1} &, subgroups];

  (* plot text *)
  Graphics[{MapThread[
     Rotate[FilledCurve[#1, #2], #3, {0, 0}] &, {curves[[#]] & /@ 
       subgroups, pts, -Rescale[centers, xrange, ang]}]}]]

Here, str is the string you want to place along the circle, and scale is the scaling of the text.

Example

string = "The brown fox jumped over the lazy dog";

circularText[string]

Mathematica graphics

Edit

I've adapted the code. You can now specify an arc along which you want to place the text, for example

circularText[string, {-Pi/4, Pi}]

Mathematica graphics

share|improve this answer
3  
So... this is a slow fox and not a quick one? –  rm -rf May 18 '12 at 17:29
    
@R.M Speed is relative anyway. –  Heike May 18 '12 at 17:36

Here is a starting point:

txt = "This is some text to warp." // Characters;
arc = 1;
range = Range[0, arc, arc/(Length@txt - 1)];
coords = {-Cos[#], Sin[#]} & /@ range;
Graphics[
  MapThread[
   Rotate[Text[Style[#, FontFamily -> "Courier"], #2], 90° - #3] &,
   {txt, coords, range}]
]

Mathematica graphics

share|improve this answer
    
@R.M thanks for the edit; I wish there was a robust and convenient method for doing that. –  Mr.Wizard May 18 '12 at 17:10
    
I agree... I make these changes very often on the site, and I've partly automated my work with a vim script that does the replacements when it's a big code block with lots of \[blah] (see my edit here for example). For smaller ones like this and David's, I do it by hand. I keep that question in mind, because if I can fix some pending issues with what I have now and turn my script to a nicely wrapped function in mma, it'll be a robust answer, because vim is extremely portable and you can find/install it for any OS. Some day I'll get to it... –  rm -rf May 18 '12 at 17:23
    
Thanks everyone, this works great! –  M.R. May 18 '12 at 17:54

Modifying an example from the help on FilledCurve[]:

Module[{l = 
   Cases[First[First[ImportString[ExportString[Style["CIRCLE", Bold, FontFamily -> "Courier", 
         FontSize -> 12], "PDF"], "TextMode" -> "Outlines"]]], 
   FilledCurve[a__] :> {EdgeForm[Black], Yellow, FilledCurve[a]}, Infinity]}, 
 Animate[Graphics[{Red, Circle[{0, 0}, 1.5], {l /. {x_Real, y_Real} :> 
       y^(1/10) { Sin[t + 1/100 Norm[x, y]], 
                  Cos[t + 1/100 Norm[x, y]]}}}], {t, 0, 2 Pi}, 
  AnimationRunning -> False, SaveDefinitions -> True]]

enter image description here

share|improve this answer
    
+1 What's nice about FilledCurve is that it can be used for any shape of curve. –  David Carraher May 18 '12 at 16:23

Here's an approach that works alright with both fixed width and proportional fonts, and gives you some flexibility when it comes to the style of the text. It uses the common, hacky trick of rasterizing the text beforehand to work out the approximate sizes of the letters, and it uses the Framed option to rasterize all the letters at once so we can pick the frames out of the ImageData using cases (which is much, much faster than rasterizing the letters one by one).

sizes[text_String, style_] :=
 With[{data =
    ImageData@Rasterize@Row[Map[
        Framed[Text[Style[#1, style]], FrameStyle -> Magenta] &,
        Characters@text], " "],
   pixel = List @@ (N@Magenta) 
   },
  With[{row = Part[data, First@First@Position[data, pixel, 2, 1]]},
   Part[Length /@ Split[row], Span[1, All, 2]]]]

The frames are magic pink to make them even easier to pick out. Then all that remains is to draw the text on the circle. I use the relative sizes of the letters to work out the angles, and use Scaled with the FontSize option to Style to make the letters the right size in the graphics. I also introduced some (hard-coded) fudge factors to make things look OK and not get cut off; playing with them some more (or better, setting up a Manipulate to do it interactively!) may get you results you like better.

circularize[text_String, style_: "Subtitle"] :=
 With[{sizes = sizes[text, style], n = StringLength@text, 
   imageSize = 400},
  With[{
    angles = 2 Pi (Accumulate@sizes - First@sizes)/Total[sizes],
    scale = 0.8*2 Pi/n
    },
   Graphics[
    MapThread[
     Rotate[
       Text[Style[#1, style, FontSize -> Scaled[scale]], 
        Through[{Sin, Cos}@#2]], -#2] &,
     {Characters@text, angles}]]
   ]]

EDIT because this answer is useless without pics!

enter image description here

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.