How do I make an image “nearly” black and white?

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[
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?

-

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)

-
This is awesome, and it works in version 8. Thanks! –  Andrew Dec 22 '12 at 20:30
If you replace the Blur with an Image[#, ImageType[im1]]&, you get smooth contours without the extra blurring: i.stack.imgur.com/dI9XW.png. The only reason it didn't work without Blur was that Binarize implicitly converted the ImageType to Bit. P.S. You could also use Scaled[4] instead of 2500 if you want it to work without modification for images of different sizes. –  Rahul Narain Dec 23 '12 at 0:06
Welcome to the 20K club –  belisarius Feb 6 '13 at 23:59

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... :)

-
Thanks! Unfortunately, I do not have Mathematica 9 :-( . I am using version 8. –  Andrew Dec 22 '12 at 20:00
Oops, sorry. Perhaps Santa will bring you a welcome upgrade... :) –  cormullion Dec 22 '12 at 20:06
Yep, hopefully he will! :-) –  Andrew Dec 22 '12 at 20:10

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


-

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]} & @
{{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 @@@ #,
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.

-
Nice, but your first example doesn't work for me - gives a black image. Could be a stray 0? –  cormullion Dec 23 '12 at 10:31
@cormullion Do the others work? ImageAdjust may have changed since v7. –  Mr.Wizard Dec 23 '12 at 11:42
they don't work as you show them: the first Manipulate is black with those settings, the second one doesn't really work as it should. Strange eh? –  cormullion Dec 23 '12 at 18:16
I do confirm that it works in V7, but gives black rectangle in both V8 and V9. –  Leonid Shifrin Dec 23 '12 at 18:57
@mr.wizard Why don't you set up a donation button on your profile page somewhere so that we could all contribute to your "upgrade to a current version of Mathematia" fund... :) –  cormullion Dec 23 '12 at 22:45

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 =
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:

-

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.

-
Like the silent movie! –  cormullion Dec 23 '12 at 18:26