4
$\begingroup$

I'd like to compute the proper FontSize for a given piece of text to fill a given Rectangle.

size={200,50};
style={FontColor->Black,FontSize->Automatic,TextAlignment -> Left, LineIndentMaxFraction -> 0};
img=ConstantImage[RandomColor[],size]
text = ResourceFunction["RandomText"][#]&/@{1,3,10}

enter image description here

In this example, we want the text to neatly fill the image over which it is inset:

Overlay[{img, Pane[Style[#, FontSize->#2, Sequence@@style], size/2]}]& @@@ Thread[{text,
   {13, 8, 4.5} (* how to find these 3 numbers? *)}]

enter image description here

So how does one compute the filling font size?

Details:

Here's one clunky way to do this in javascript with a loop: https://codepen.io/LukeXF/pen/yOQWNb

$\endgroup$
3
  • 1
    $\begingroup$ Might the use of DiscretizeGraphics[Text[...]] in the text3D discussion give you some ideas? Here: mathematica.stackexchange.com/questions/131798/… $\endgroup$
    – Nicholas G
    Apr 26 at 23:55
  • 3
    $\begingroup$ perhaps Overlay[{img, Pane[Style[#, FontColor -> Black, TextAlignment -> Left, LineIndentMaxFraction -> 0], size/2, ImageSizeAction -> "ResizeToFit"]}] & /@ text? $\endgroup$
    – kglr
    Apr 27 at 5:21
  • $\begingroup$ @kglr I need an explicit FontSize value $\endgroup$
    – user5601
    Jun 21 at 1:28

2 Answers 2

6
$\begingroup$

To prevent confusion, I will provide a new answer rather than edit my previous one. It is using elements of my previous answers with several important modifications.

  1. The text is always centered.
  2. Use of Image Crop on the text to get a tighter fit.
  3. There are different ways of arranging multiword text (less lines with smaller font versus more lines with larger font). I now use another function (adjustToRatio[]) to insert carriage returns between selected words to get a ratio of width over height that is closest to the background image.
adjustToRatio[text_String, {x_, y_}] := 
 Module[{split, tup, dropSplit, rif, finText, id, ratios, targetRatio,
    near, p},
  split = StringSplit[text];
  tup = Tuples[{" ", "\n"}, Length[split] - 1];
  dropSplit = Drop[split, -1];
  
  rif = Riffle[dropSplit, #] & /@ tup;
  finText = (StringJoin @@ #) ~~ Last[split] & /@ rif;
  id = ImageDimensions[ImageCrop[
       Rasterize[
        pp = 
         Pane[Text[Style[#, TextAlignment -> Center]], 
          ImageSize -> {Automatic, x/2}, 
          ContentPadding -> False, FrameMargins -> None, 
          Appearance -> "InputField"], "Image"], Padding -> None]] & /@
     finText;
  
  ratios = #[[1]]/#[[2]] & /@ id;
  targetRatio = x/y;
  near = Nearest[ratios, targetRatio];
  p = Position[ratios, near[[1]]];
  finText[[First@Flatten@p]]
  ]

fitText[] := 
 Module[{fontSizes, size, style, text, lowVal, hiVal, lastTrials, 
   escape, possibilities, trialIndex, trialFont, result},
  fontSizes = Table[i, {i, 4, 100, .1}];
  size = {300, 120};
  img = ConstantImage[Green, size];
  style = {TextAlignment -> Center, FontColor -> Black, 
    FontWeight -> RandomChoice[{Bold, Plain}], 
    FontSlant -> RandomChoice[{Plain, Italic}], FontSize -> Automatic,
     FontFamily -> (ff = RandomChoice[$FontFamilies])};
  text = 
   ResourceFunction["RandomText"][RandomChoice[Range[1, 5]], "Word"];
  text = adjustToRatio[text, size];
  lowVal = 1;
  hiVal = Length[fontSizes];
  lastTrial = 0;
  escape = False;
  Do[
   possibilities = hiVal + lowVal - 1;
   trialIndex = Ceiling[possibilities/2.];
   trialFont = fontSizes[[trialIndex]];
   dim = 
    ImageDimensions[
     ImageCrop[
      Rasterize[
       pp = 
        Pane[
         Text[
          Style[text, FontSize -> trialFont, TextAlignment -> Center, 
           Sequence @@ style]], ImageSize -> {Automatic, size[[1]]/2},
          ContentPadding -> False, FrameMargins -> None, 
         Appearance -> "InputField"], "Image"], Padding -> None]];
   d = dim[[1]];
   
   If[d >= ImageDimensions[img][[1]] - 6, hiVal = trialIndex - 1; 
    lastTrial = trialFont; Continue[]];
   
   If[lastTrial == trialFont, escape = True];
   lastTrial = trialFont;
   rast = 
    ColorReplace[
     ImageCrop[
      Rasterize[
       p = 
        Pane[
         Style[text, FontSize -> trialFont, 
          LineSpacing -> {0, trialFont}, Sequence @@ style], size/2, 
         ImageSize -> {size[[1]]/2, Automatic}], "Image"], 
      Padding -> None], White -> Transparent];
   result = 
    If[ImageDimensions[rast][[2]] < ImageDimensions[img][[2]], True, 
     False];
   
   If[result, lowVal = trialIndex + 1, hiVal = trialIndex - 1];
   If[escape, Break[]];
   , 100];
  
  {trialFont, 
   Overlay[{ImageResize[img, size/2], rast}, 
    Alignment -> {Center, Center}, ContentPadding -> False]}
  ]

Here is a test with 100 different texts. Only images are shown, but each result comes with the font size. In the version given by the above function, the maximum font size is 100 (subdivided in 0.1 increments).

enter image description here

$\endgroup$
5
  • 1
    $\begingroup$ Two suggestions: 1) Instead of kludgy ColorReplace[..., White -> Transparent] use Rasterize with option Background -> None; 2) With the previous change ImageCrop[img] won't work anymore, so use ImagePad[img, -BorderDimensions[img, 0]]] instead. $\endgroup$ Jun 27 at 2:16
  • $\begingroup$ Also, I'm not sure if 50.8 is a valid fontsize... Are there lists of valid fontsize increments for each font? $\endgroup$
    – user5601
    Jun 27 at 14:41
  • $\begingroup$ Also still seeing lots of these: imgur.com/a/yKBcmqa $\endgroup$
    – user5601
    Jun 27 at 15:43
  • $\begingroup$ I don't know about font size. I figured that the closest font size would be returned. I just fixed a bug regarding the use of size[[]] in adjustToRatio[] instead of x, which represents the same value locally. I am getting a good fit, particularly for one word. $\endgroup$ Jun 27 at 17:18
  • $\begingroup$ @Jean-Pierre Thanks for your help on this one, your updates have it looking much better now, accepted! $\endgroup$
    – user5601
    Jun 27 at 19:06
3
+100
$\begingroup$
size = {200, 50};
style = {FontColor -> Black, FontSize -> Automatic, 
   TextAlignment -> Left, LineIndentMaxFraction -> 0};
img = ConstantImage[LightYellow, size];
text = ResourceFunction["RandomText"][#] & /@ {1, 3, 5, 10};
First[If[
      Rasterize[
         p = 
          Pane[Style[#, FontSize -> #2, Sequence @@ style], size/2, 
           ImageSize -> {size[[1]]/2, Automatic}], 
         "RasterSize"][[2]] <= ImageDimensions[img][[2]], {#2, 
       Overlay[{ImageResize[img, size/2], p}]}, Nothing] & @@@ 
    Thread[{#, Table[i, {i, 20, 4, -0.5}]}]] & /@ text

enter image description here

Response from OP:

So this is a great start but a few things before I accept:

  1. Not always is the maximal value being computed (see below). There should be no margin space between the glyph and rectangle edge.
  2. Handle any font family and font styling.
  3. Should work for any length text, even single characters, so the search should start from a much high number (I put 70 below) and so it needs to be much faster.

Improved test example generator:

size = {300, 120};
style = {FontColor -> Black, FontWeight -> RandomChoice[{Bold,Plain}], FontSlant -> RandomChoice[{Plain,Italic}] , FontSize -> Automatic, FontFamily->RandomChoice[$FontFamilies], 
   TextAlignment -> Center};
text = ResourceFunction["RandomText"][#] & /@ {1, 3, 5, 10};
{Slider2D[Dynamic@size,{{100,50},{500,200},{10,10}},ImageSize->{100,50}],Dynamic[size]}

img = ConstantImage[Green, size];
AbsoluteTiming@First[If[
      Rasterize[
         p = 
          Pane[Style[#, FontSize -> #2, Sequence @@ style], size/2, 
           ImageSize -> {size[[1]]/2, Automatic}(*FrameMargins->{0,0}*)], 
         "RasterSize"][[2]] <= ImageDimensions[img][[2]], {#2, 
       Overlay[{ImageResize[img, size/2], p}]}, Nothing] & @@@ 
    Thread[{#, Table[i, {i, 70, 4, -.5}]}]] & /@ text

Running this gives many examples, the first one I tried didn't choose a maximal size to fill the rect exactly: see the word "pottage" below, the loop gave 42, but 44 works too as you can see.

enter image description here

==========================================

Thank you for your comments. Here is a much faster version using a precision of 0.25 points. Italics are a pain sometimes. I also played with the alignment of the overlay itself. This version picks one random text (between 1 and 10 words) every time.

fitText[] := 
 Module[{fontSizes, size, style, text, lowVal, hiVal, lastTrials, 
   escape, possibilities, trialIndex, trialFont, result, img},
  fontSizes = Table[i, {i, 4, 70, .25}];
  size = {300, 120};
  img = ConstantImage[Green, size];
  style = {FontColor -> Black, 
    FontWeight -> RandomChoice[{Bold, Plain}], 
    FontSlant -> RandomChoice[{Plain, Italic}], FontSize -> Automatic,
     FontFamily -> RandomChoice[$FontFamilies], 
    TextAlignment -> Center};
  text = ResourceFunction["RandomText"][RandomChoice[Range[1, 10]]];
  
  lowVal = 1;
  hiVal = Length[fontSizes];
  lastTrials = {};
  escape = False;
  Do[
   possibilities = hiVal + lowVal - 1;
   trialIndex = Ceiling[possibilities/2.];
   trialFont = fontSizes[[trialIndex]];
   If[MemberQ[lastTrials, trialFont], escape = True];
   AppendTo[lastTrials, trialFont];
   result = 
    If[Rasterize[
        p = 
         Pane[Style[text, FontSize -> trialFont, Sequence @@ style], 
          size/2, ImageSize -> {size[[1]]/2, Automatic}], 
        "RasterSize"][[2]] <= ImageDimensions[img][[2]], True, 
     False];
   If[result, lowVal = trialIndex + 1, hiVal = trialIndex - 1];
   If[escape, Break[]];
   , 100];
  
  {trialFont, 
   Overlay[{ImageResize[img, size/2], p}, 
    Alignment -> {Center, Center}]}
  ]

Here is the result of calling Table[fitText[], 30]

enter image description here

Final Response from OP:

That is an improvement! I'm still seeing many cases like this where the font could easily be bigger:

enter image description here

The results should all be "tighter fits" and have less marginal space (e.g. look like the pink boxes I drew).

$\endgroup$
3
  • 1
    $\begingroup$ @user5601 - can you please make your response here in the comments? Editing another user's answer is highly unorthodox to say the least. It also makes the answer unreadable $\endgroup$
    – Jason B.
    Jun 23 at 20:49
  • $\begingroup$ @JasonB. But I need to show him images... can you suggest a better way? $\endgroup$
    – user5601
    Jun 24 at 21:30
  • $\begingroup$ @user5601 Normally the OP adds new sections to the original question instead of editing the answer. $\endgroup$ Jun 27 at 2:11

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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