Keeping Font Relative Size to Object/Graphics/Plot Object upon Resize

Question

I want to keep the text generated within a graph/plot to remain the same relative to an element (a disk of size 0.2) of the image upon resize, not the image itself, while maintaining the original aspect ratio (not having to fix the aspect ratio to 1). Using a LayeredGraphPlot with the following code:

Clear[set1, set2]
set1 = Table["" -> " ", {i, 1, 7, 1}];
set1[[1]] = "A" -> "B";
set1[[2]] = "B" -> "C";
set1[[3]] = "D" -> "F";
set1[[4]] = "A" -> "F";
set1[[5]] = "G" -> "B";
set1[[6]] = "H" -> "C";
set1[[7]] = "C" -> "G";

set2 = Table["" -> " ", {i, 1, 7, 1}];
set2[[1]] = "B" -> "A";
set2[[2]] = "B" -> "C";
set2[[3]] = "D" -> "G";
set2[[4]] = "A" -> "F";
set2[[5]] = "G" -> "H";
set2[[6]] = "H" -> "D";
set2[[7]] = "B" -> "G";

LayeredGraphPlot[set1, Bottom,
 VertexLabeling -> True,
 DirectedEdges -> True, 
 EdgeRenderingFunction -> ({Black, Thickness[0.04], Arrow[#1, .05]} &),
 VertexRenderingFunction -> ({EdgeForm[{RGBColor[0/225, 0/255, 0/255],
        Thickness[0.02]}],
     RGBColor[255/255, 255/255, 255/255],
     Disk[#1, 0.2],
     RGBColor[0/225, 0/255, 0/255], 
     Style[Text[#2, #1], FontFamily -> "Arial", Bold, 
      FontSize -> Scaled[0.05]],
     RGBColor[0/225, 0/255, 0/255]} &), 
 PlotStyle -> Arrowheads[{{0.1, 0.8}}],
 PlotRangePadding -> 0]

I generate an image that makes the internal text labels (based on FontSize->Scaled, instead of picking the font size in printer's points) at pretty much the size I want, which happens to be 5% of the total image size.

However, if I change the data set to

set2 = Table["" -> " ", {i, 1, 7, 1}];
set2[[1]] = "B" -> "A";
set2[[2]] = "B" -> "C";
set2[[3]] = "D" -> "G";
set2[[4]] = "A" -> "F";
set2[[5]] = "G" -> "H";
set2[[6]] = "H" -> "D";
set2[[7]] = "B" -> "G";

and re-plot, the size of the font, the text labels are still 5% of the total image, but because the image dimensions are different, the text is no longer in the correct scale to the individual disks.

Is there a way to make the text always be scaled the same to the disk size, rather than the total image size, so upon resize of the image, both disk and text grow/shrink the same amount?

Answer 1

First, some remark : with Mathematica you don't have to "initialize" lists : you can directly input set1 and set2 like this :

set1 = {"A" -> "B", "B" -> "C", "D" -> "F", "A" -> "F", "G" -> "B", 
   "H" -> "C", "C" -> "G"};

set2 = {"B" -> "A", "B" -> "C", "D" -> "G", "A" -> "F", "G" -> "H", 
   "H" -> "D", "B" -> "G"};

In order the texts and disks scale the same way, you just have to use also Scaled inside Disk to scale the radius.

I rewrote your code as a function (of course, adjust the parameters in Scaled to suit your exact needs.)

draw[set_, aspectratio_: 0] := 
 Module[{ar}, 
  ar = If[aspectratio == 0, 
    1./Divide @@ ImageDimensions@Image@LayeredGraphPlot[set, Bottom], aspectratio]; 
  LayeredGraphPlot[set, Bottom, VertexLabeling -> True, 
   DirectedEdges -> True, 
   EdgeRenderingFunction -> ({Black, Thickness[0.04], 
       Arrow[#1, .05]} &), 
   VertexRenderingFunction -> ({EdgeForm[{Black, Thickness[0.02]}], 
       White, Disk[#1, Scaled[{0.1, 0.1/ar}]], Black, 
       Style[Text[#2, #1], FontFamily -> "Arial", Bold, 
        FontSize -> Scaled[0.05]]} &), 
   PlotStyle -> Arrowheads[{{0.1, 0.8}}], PlotRangePadding -> 0., 
   Axes -> False, AspectRatio -> ar]]

By default, you get the default (very close to) aspect ratio of LayeredGraphPlot :

draw[set1]

draw[set2]

But you can also specify any aspect ratio by adding a second parameter, for example :

draw[set2, 2]