How do I make an image "nearly" black and white?

Question

Using the following code, I downloaded an image from the web and adjusted the image to obtain the "negation" of the image:

im1 = Import["http://www.furnituremaker.com/images/Craftsman.gif"]

im2 = ColorConvert[
 ImageAdjust[
  ColorQuantize[ColorNegate[im1], 20, Dithering -> False], 1],
 "Grayscale"
 ]

Now, I would like to convert this to an image that is "nearly" black and white. By "nearly," I mean that the resulting image may have a small amount of gray at the interface of the black and white, so as to keep the resulting image smooth. (It seems like simply rasterizing an image can sometimes look bad.) How can I accomplish this?

I tried using Darker, but it just makes the background gray again:

im3 = Darker[im2]

Instead I would like to somehow adjust the saturation so that the line art and text appears black. ColorConvert seems like a possibility, but in the documentation I do not see how to specify a black and white color space. Can you please help me?

Answer 1

im1 = Import["http://www.furnituremaker.com/images/Craftsman.gif"]

Perhaps something like this?

ColorNegate@Binarize@ImageResize[im1, Scaled[4]]~Image~
 ImageType[im1]~ImageResize~ImageDimensions[im1]

(thanks to @RahulNarain's for his suggestions)

Answer 2

A fun new command in Mathematica 9 is ColorReplace:

ColorReplace[im1, {Black -> White, Brown -> Black}]

You could probably play with these and Blur functions too to get the results you want. (I guessed at Brown... :)

Answer 3

Using ImageAdjust again to perform gamma correction on im2, using either

 ImageAdjust[im2, {0, 0, 3.}]

or

 ImageApply[Clip[#^3., {0, 1}] &, im2]

gives

Combining the above with @Rojo's nested ImageResize in Manipulate to play with various values for the gamma parameter:

 Manipulate[ImageResize[
  ImageAdjust[ImageResize[im2, 3000.], {0, 0, \[Gamma]}],
  ImageDimensions[im2]], 
  {{\[Gamma], 1., "\[Gamma]"}, 0.001, 5., .1}]

or

Manipulate[ImageResize[
 ImageApply[Clip[#^\[Gamma], {0, 1}] &,
  ImageResize[im2, 3000.]],
  ImageDimensions[im2]],
  {{\[Gamma], 1., "\[Gamma]"}, 0.001, 5., .1}]

Answer 4

You really just need a "levels" adjustment here.

Directly:

im1 = Import["http://www.furnituremaker.com/images/Craftsman.gif"];

ImageAdjust[im1, 0, {0.44, 0.2}] ~ColorConvert~ "Grayscale"

To create the inversion you just place the larger value first.

You could find the clip points with analysis of the image or manually like this, aided by a histogram:

Manipulate[
 Column@{{b, w}, 
     Image[ColorConvert[#, "Grayscale"], ImageSize -> 540], 
     Show[ImageHistogram@#, ImageSize -> 540]} & @ 
   ImageAdjust[im1, 0, {b, w}],
 {{b, 0}, 0, 1},
 {{w, 1}, 0, 1}
]

You can see from the histogram that (of course, given the color) not all channels clip at the same time. You could adjust each channel manually with a control as above, but it will be easier to pick the white/black points from the image itself, which is what the Manipulate below does.

Manipulate[
 Image[#, Magnification -> 1] & @
   If[Nor @@ SameQ @@@ #,
     ColorCombine @ MapThread[ImageAdjust[#, 0, #2] &, {ColorSeparate@im1, #}],
     im1
   ] &[Extract[Reverse[ImageData[im1]\[Transpose], {2}], Ceiling /@ pt]\[Transpose]],
 {{pt, {{10, 20}, {10, 10}}}, Locator}
]

• Just drag the locators to the colors that should be black and white in the final image.

• When identical colors in any channel are selected the original is shown, to avoid errors.

Answer 5

Here is another approach. This only works in v9; the idea is to convert to Lab, then pick the L channel, and finally apply curves to get the image to look good:

im = Import["http://www.furnituremaker.com/images/Craftsman.gif"];
imlab = ColorConvert[im, "LAB"];
lum = 1-ImageData[imlab][[All, All, 1]];

Now lum contains the L channel values. Next construct the curves interface (please note, this is horrible code, but it's the best I can do and it works--if anybody wants to improve it, please go ahead):

image1 = Image@lum;
Column[
 {
  DynamicModule[{pts = {{0, 0}, {1, 1}}}, Dynamic[];
   LocatorPane[Dynamic[pts], 
    Dynamic[curve = InterpolatingPolynomial[pts, x];
     image2 = 
      ImageAdjust[
       ImageApply[Function[{x}, Evaluate@curve], image1, 
        Interleaving -> False]];
     Dynamic[
      Plot[curve, {x, 0, 3}, PlotRange -> {{0, 1}, {0, 1}}, 
       ImageSize -> Full]]], LocatorAutoCreate -> True]],
  Dynamic@ImageHistogram[image2, ImageSize -> Full], 
  Dynamic[Show[image2, ImageSize -> Full]]}
 ]

Note that control- or command-clicking on the curve inserts extra points:

Answer 6

I would go with splitting into the r, g anb channels and creating a grayscale image from them. The simplest case would be to take only the green (say) channel; slightly more complicated is to take weighted superpositions (a bit like taking black and white photos with coloured filters on the lens).

Using the simplest possible image and dynamic functions (because a) I am not sure what's new in v9 b) I know very little about frontend programming), this should work:

import:

im = Import["http://www.furnituremaker.com/images/Craftsman.gif"];

split into channels:

channels = Table[ImageData[im][[All, All, c]], {c, 1, 3}];

initialize our weights: {r, g, b} = {0.1, 0.1, .98};

create create the black and white image with the sliders to control the ratios:

Column[
 {Slider[Dynamic[r], {0, 1}],
  Slider[Dynamic[g], {0, 1}],
  Slider[Dynamic[b], {0, 1}],
  Dynamic[{r, g, b} = Normalize@{r, g, b};
   Image[1 - ({r, g, b}.channels), ImageSize -> Full]
   ]}
 ]

Note that as you manipulate a slider, the others shift around. This is because I normalize {r,g,b} to have unit magnitude. See a (silent) screen recording here (the colour inversion isn't done there though):

It's much more dramatic with more colourful images; try it with im = Import["https://dl.dropbox.com/u/402625/_JSC1045-Edit-2.jpg"] for instance.