Make a text string fill a rectangle - image

Question

Suppose I want a string, say "123", to fill a given rectangle, like so:
Show[Plot[x, {x, 0, 1}],
Graphics[{EdgeForm[Thick], Yellow, Rectangle[{.1, .5}, {.4, .9}]}],
Graphics[Text[Style["123", Red, Bold, 67], {.1, .5}, {-1, -1}]]]
But I hand-tuned the font size there (67) so that it would fill up the rectangle.
How would you make an arbitrary string fill up an arbitrary rectangle?

Answer 1

I believe that this is a known difficult problem. The best answer I could find is from John Fultz.
TextRect[text_, {{left_, bottom_}, {right_, top_}}] :=
Inset[
Pane[text, {Scaled[1], Scaled[1]},
ImageSizeAction -> "ResizeToFit", Alignment -> Center],
{left, bottom}, {Left, Bottom}, {right - left, top - bottom}]
Show[
Plot[x, {x, 0, 1}],
Graphics[{
{EdgeForm[Thick], Yellow, Rectangle[{.1, .5}, {.4, .9}]},
TextRect[Style["123", Red, Bold], {{.1, .5}, {.4, .9}}]
}]
]

Answer 2

Here's an alternate approach that converts the text to a texture that gets mapped to a polygon. This has the feature of stretching the text to fit the region (since it's not really text anymore.)
Show[Plot[x, {x, 0, 1}],
Graphics[{EdgeForm[Thick], Yellow, Rectangle[{.1, .5}, {.4, .9}]}],
Graphics[{Texture[ImageData[
Rasterize[Style["123", Red, Bold], "Image", RasterSize -> 300,
Background -> None]]],
Polygon[{{0.1, 0.5}, {0.4, 0.5}, {0.4, 0.9}, {0.1, 0.9}},
VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}]]
As a function for easier comparison:
(* Render string/style s to fill a rectangle with left/bottom corner {l,b} and
right/top corner {r,t}. *)
textrect[s_, {{l_,b_},{r_,t_}}] := Graphics[{
Texture[ImageData[Rasterize[s, "Image", RasterSize->300, Background->None]]],
Polygon[{{l,b}, {r,b}, {r,t}, {l,t}},
VertexTextureCoordinates->{{0,0},{1,0},{1,1},{0,1}}]}]

Answer 3

The suggested solution didn't work when the Plot wasn't there, I used the PlotRange option to solve it. I wrapped it in a function; Opacity, text color, etc; should be made into options;
textBox[text_, color_, position_: {0, 0}, width_: 2, height_: 1] :=
Graphics[{
{
color, Opacity[.1],
Rectangle[position, position + {width, height},
RoundingRadius -> 0.1]
}
,
Inset[
Pane[text, {Scaled[1], Scaled[1]},
ImageSizeAction -> "ResizeToFit", Alignment -> Center],
position, {Left, Bottom}, {width, height}]
}, PlotRange ->
Transpose[{position, position + {width, height}}]];