How can I standardize the coordinate origin for exported/imported outlines?

Question

There is a widely known trick of converting letters to curves:

TextToOutlines[style_] := 
 ImportString[ExportString[style, "PDF"], "TextMode" -> "Outlines"][[1, 1]]

But it seems to assign the y coordinate without any order that would be obvious to me:

Show[Graphics@TextToOutlines@
    Style["Fubar", FontFamily -> "Helvetica", FontSize -> #] &
    /@ {1, 2, 4, 8},
  Axes -> True]

produces:

I would like to have the typographical baseline (or better median line) of the imported letters identical with the x axis. How could I do that? Is there some extra margin/padding in the import or export? Or something else?

Answer 1

One possible technique is to use a reference letter (e.g., "x") to determine the baseline (and/or midline). I imagine "x" should work for most cases, though definitely not all (see last example below).

This should take care of the "different strings" issues described in the comment of @user6014's answer. I'm not a typography expert by any means, but hopefully I have enough of it right to work for this problem.

---

Examples

Different texts

exampleTexts = {"bar", "_bar"};

Show[
 Graphics[
    {EdgeForm[{Black, Opacity[0.6]}],
     TextToOutlineShifted[
      #,
      FontFamily -> "Helvetica",
      FontSize -> 10,
      FontColor -> RandomColor[],
      FontOpacity -> 0.6,
      AlignLeft -> True
      ]
     }
    ] & /@ exampleTexts,
 Axes -> True
 ]

Different font sizes

exampleFontSizes = {1, 2, 4, 8};

Show[
 Graphics[
    {EdgeForm[{Black, Opacity[0.6]}],
     TextToOutlineShifted[
      "Fubar",
      FontFamily -> "Helvetica",
      FontSize -> #,
      FontColor -> RandomColor[],
      FontOpacity -> 0.6,
      AlignLeft -> True
      ]
     }
    ] & /@ exampleFontSizes,
 Axes -> True
 ]

Example where this doesn't work

A quick fix here (depending on the font) would be to try to use a different reference letter.

Show[
 Graphics[
  {EdgeForm[{Black, Opacity[0.6]}],
   TextToOutlineShifted[
    "Fubar",
    FontFamily -> "Zapfino",
    FontSize -> 12,
    FontColor -> RandomColor[],
    FontOpacity -> 0.6,
    AlignLeft -> True,
    ShowReferenceLetters -> True
    ]
   }
  ],
 Axes -> True
 ]

---

TextToOutlineShifted

Along with the default options from Style, TextToOutlineShifted also takes:

• ShiftTo:
  • "Baseline" (default): Aligns the horizontal axis to the bottom of the reference "x"
  • "Midline": Aligns the horizontal axis to the top of the reference "x"
  • "Center": Aligns to the line halfway between the baseline and midline (not sure if this is a thing, or is even useful, but I added it just in case)
• ShowReferenceLetters: If True, displays the reference "x" used.
• AlignLeft: If True, aligns the leftmost point of the content text with the vertical axis.

Note here I've defined TextToOutline as follows:

TextToOutline[text_, opts : OptionsPattern[]] := 
  ImportString[
    ExportString[Style[text, FilterRules[{opts}, Options[Style]]], 
     "PDF"], "TextMode" -> "Outlines"][[1, 1]];

...and the code for TextToOutlineShifted:

Options[TextToOutlineShifted] = Join[
   {
    ShiftTo -> "Baseline",
    ShowReferenceLetters -> False,
    AlignLeft -> False
    },
   Options[Style]
   ];

TextToOutlineShifted[text_, opts : OptionsPattern[]] := Module[
   {xref = TextToOutline["x", opts],
    content = TextToOutline[text, opts],
    cbb,
    xrefbb,
    contentbb,
    shift,
    leftshift},
   
   cbb[letter_] := 
    CoordinateBoundingBox[Flatten[letter[[2, 1, 1, 2]], 1]];
   xrefbb = cbb[xref];
   contentbb = cbb[content];
   
   shift = -Piecewise[
      {
       {{xrefbb[[1, 1]], xrefbb[[1, 2]]}, 
        OptionValue[ShiftTo] == "Baseline"},
       {{xrefbb[[1, 1]], xrefbb[[2, 2]]}, 
        OptionValue[ShiftTo] == "Midline"},
       {{xrefbb[[1, 1]], Mean@{xrefbb[[1, 2]], xrefbb[[2, 2]]}}, 
        OptionValue[ShiftTo] == "Center"}
       }
      ];
   
   leftshift = If[
     OptionValue[AlignLeft],
     {-contentbb[[1, 1]] - xrefbb[[1, 1]], 0},
     {0, 0}
     ];
   
   Translate[
    If[OptionValue[ShowReferenceLetters], {xref, content}, content], 
    shift + leftshift]
   ];

In any case, that's my attempt for the moment. (Feedback is very much welcome, as always.) Hopefully everything is clear, and that it's at least somewhat close to what you have in mind!

New Version: Added ReferenceLetter as an option (for easier tinkering)

Options[TextToOutlineShifted] = Join[
   {
    ShiftTo -> "Baseline",
    ReferenceLetter -> "x",
    ShowReferenceLetters -> False,
    AlignLeft -> False
    },
   Options[Style]
   ];

TextToOutlineShifted[text_, opts : OptionsPattern[]] := Module[
   {referenceLetter = 
     TextToOutline[OptionValue[ReferenceLetter], opts],
    content = TextToOutline[text, opts],
    getBoundingBox,
    referenceLetterBoundingBox,
    contentBoundingBox,
    shift,
    leftShift},
   
   getBoundingBox[textCurve_] := 
    CoordinateBoundingBox[Flatten[textCurve[[2, 1, 1, 2]], 1]];
   referenceLetterBoundingBox = getBoundingBox[referenceLetter];
   contentBoundingBox = getBoundingBox[content];
   
   shift = -Piecewise[
        {
         {{#[[1, 1]], #[[1, 2]]}, 
          OptionValue[ShiftTo] == "Baseline"},
         {{#[[1, 1]], #[[2, 2]]}, OptionValue[ShiftTo] == "Midline"},
         {{#[[1, 1]], Mean@{#[[1, 2]], #[[2, 2]]}}, 
          OptionValue[ShiftTo] == "Center"}
         }
        ] &@(referenceLetterBoundingBox);
   
   leftShift = If[
     OptionValue[AlignLeft],
     {-contentBoundingBox[[1, 1]] - 
       referenceLetterBoundingBox[[1, 1]], 0},
     {0, 0}
     ];
   
   Translate[
    If[OptionValue[ShowReferenceLetters], {referenceLetter, content}, 
     content], shift + leftShift]
   ];

Answer 2

Not a answer

If you replace ExportString[style, "PDF"] by ExportString[Style[style,Black], "PDF"], you get :

I don't know why.

Answer 3

Here is a method that finds the earliest x value and the mean y value used in creating the characters, and subtracts all content in the graphic by these values to normalize the first character to {0, 0}:

TextToOutlines[style_] := Module[{content, x, y, xadj, yadj},
  content = 
   ImportString[ExportString[style, "PDF"], 
     "TextMode" -> "Outlines"][[1, 1]];
  {x, y} = 
   MinMax /@ 
    Transpose[Cases[content[[2, 1, 1, 2]], {_?NumericQ, _}, 2]];
  xadj = x[[1]]; yadj = Mean@y;
  ReplaceAll[
   content, {x_?NumericQ, y_?NumericQ} :> {x - xadj, y - yadj}]
  ]

Show[Graphics@
    TextToOutlines@
     Style["Fubar", FontColor -> RandomColor[], 
      FontFamily -> "Helvetica", FontSize -> #] & /@ {8, 4, 2, 1}, 
 Axes -> True]