Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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:

enter image description here

Result:

enter image description here

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.

enter image description here

 (* 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["http://i.stack.imgur.com/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
share|improve this question

2 Answers 2

up vote 6 down vote accepted

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]]]

enter image description here

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}]

enter image description here

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]

enter image description here

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}]

enter image description here

share|improve this answer
    
Thanks a lot for your detailed explanation and workarounds. –  Putterboy Aug 28 at 12:05

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["http://i.stack.imgur.com/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}]

enter image description here

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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