How to create a stacked-alphabet image efficiently?

Question

By adopting the answers from Mr. Wizard to my previous question, I tried to create a stacked-alphabet image from a person's portrait, the alphabets were taken from the name of the portrait subject. Here is an example of Marilyn Monroe.

Marilyn Monroe's portrait:

Result:

The problem is: Why some of the alphabets,"i", "l" and their combined alphabets turned into color images. And how to obtain a faster version of the code below.

 (* change alphabets to images *)
alpha2Im[allst_] := 
  ImageResize[
   ImageCrop@
    Graphics[
     Text[Style[#, 24, FontFamily -> "Helvetica", 
         Antialiasing -> True]] &~MapThread~{allst }  ] , {18, 18}];

 (* choose appropriate alphabet-image from the alphabet image list  *)
chooseAlp[imV_, len_] := (For[i = 1, i <= len, i++,
   If[alphImageGrayPair[[i]][[2]] >= imV, 
    Return[alphImageGrayPair[[i]][[1]]] ];
  ])

Clear[i, l, r];
name = "Marilyn Monroe";
im = Import["https://i.sstatic.net/MnwCU.jpg"] ;

alphabets = 
  Subsets[Union@Characters@StringReplace[name, " " -> ""], 2];
alphImageLst = alpha2Im[#] & /@ alphabets ;
alphGrayValLst = Mean@Flatten@ImageData[#] & /@ alphImageLst;
alphImageGrayPair = 
  Sort[MapThread[
    List, {alphImageLst, alphGrayValLst}], #1[[2]] < #2[[2]] &];

imD = ImageData@im;
{imW, imH} = ImageDimensions@im  ;

avg = ConstantArray[0, {imW/4, imH/4}];
 ddata = Partition[imD, {4, 4}, 4];
For[i = 1, i <= imH/4, i++, 
 For[j = 1, j <= imW/4, j++, 
  avg[[i, j]] = Mean@Flatten[ddata[[i, j]], 1];]]

allStrips = {};
strip = {};
For[j = 1, j <= imH/4, j++,
  strip = {};
   For[k = 1, k <= imW/4, k++,
   AppendTo[  strip, chooseAlp[  avg[[j, k]], imW/4 ] ];
   ];
  AppendTo[allStrips, strip ];
   ];
allStrips // ImageAssemble

Answer 1

The colors come from subpixel rendering of the text. They show up more in thin letters because those are the ones that are stretched the most when you resize to 18x18. For example the image of the letter i comes out at 3x17 pixels before resizing:

i = ImageCrop @ Graphics[Text[
    Style["i", 24, FontFamily -> "Helvetica", Antialiasing -> True]]]

ImageDimensions[i]
(*  {3, 17}  *)

Now when you resize to 18x18 the image stretches by a factor of 6 in the horizontal direction, so the subpixel rendering becomes visible:

ImageResize[i, {18, 18}]

You can avoid stretching the image by resizing to a maximum width or height of 18 pixels (keeping the correct aspect ratio) and then using ImageCrop to pad out to 18x18:

ImageCrop[ImageResize[i, {{18}, {18}}], {18, 18}, Padding -> White]

If the stretching is desirable and you just want to get rid of the colors the simplest thing might be to start with a much larger letter:

i = ImageCrop @ Graphics[Text[
    Style["i", 200, FontFamily -> "Helvetica", Antialiasing -> True]]];
ImageResize[i, {18, 18}]

Answer 2

This is a "vectorized" version of the code in the question above in order to avoid the virtually just a "Blur output" when converting higher resolution portraits. Colored-alphabet problem was avoided by using Simon Woods' suggestion. Efforts were spent to speed up the code, however it still needs about half a minute for a 200x200 pixels conversion on my machine.

name = "Marilyn Monroe";
im = Import["https://i.sstatic.net/MnwCU.jpg"]; 
scaleRatio = 2;
imFontSize = 14;

(*change alphabets to images*)
alpha2ImVect[allst_] := 
  ImageCrop[
   ImageResize[
    ImageCrop@
     Graphics[
      Text[Style[#, 400, FontFamily -> "Helvetica", 
          Antialiasing -> True]] &~
       MapThread~{allst}], {{imFontSize}, {imFontSize}}], {imFontSize,
     imFontSize}, Padding -> White] ;

(*choose appropriate alphabet-image from the alphabet image list*)
chooseAlpVect[imV_,  row_, col_ ] := (
  alps = SelectFirst[alphGrayPair, #[[2]] >= imV &][[1]];
  Return[Text[
      Style[#, imFontSize, 
       FontFamily -> "Helvetica"  ], {halfFSize + 
        imFontSize*(col - 1), 
       imFontSize*(outH + 1 - row) - halfFSize}] &~
    MapThread~ { alps  }  ];  )

imD = ImageData@im;
{imW, imH} = ImageDimensions@im;
{outW, outH} = {imW, imH}/scaleRatio;

halfFSize = imFontSize/2;
alphabets = 
  Subsets[Union@Characters@StringReplace[name, " " -> ""], 2];
alphImageLst = alpha2ImVect[#] & /@ alphabets;

alpLen = Length[alphabets];

alphGrayPair = 
  Sort[MapThread[
    List, {alphabets, 
     Mean@Flatten@ImageData[#] & /@ (alpha2ImVect[#] & /@ 
        alphabets)}], #1[[2]] < #2[[2]] &];

avg = Developer`PartitionMap[Mean[Flatten[#, 1]] &, 
   imD, {scaleRatio, scaleRatio}, scaleRatio];

Graphics[ 
 Table[chooseAlpVect[avg[[j, k]], j, k], {j, 1, imH/scaleRatio}, 
 { k, 1, imW/scaleRatio}], 
 ImageSize -> halfFSize {imW/scaleRatio, imH/scaleRatio}]