Is there a better way to "grow" black tulips?

I used the following clumsy way to obtain a bundle of black tulips. Is there a better way to do so?

im = Import["http://i.stack.imgur.com/qclHT.jpg"]

cols = DominantColors[im, 9]
rim1 = RemoveBackground[im, {"Background", { cols[[2]], 0.1}}];
rim2 = RemoveBackground[rim1, {"Background", { cols[[3]], 0.1}}];
rim3 = RemoveBackground[rim2, {"Background", { cols[[5]], 0.1}}] ;
rim4 = RemoveBackground[rim3, {"Background", { cols[[7]], 0.1}}] ;
rim5 = RemoveBackground[rim4, {"Background", { cols[[8]], 0.1}}] ;
rim6 = RemoveBackground[rim5, {"Background", { cols[[9]], 0.1}}] ;
ImageCompose[  ColorConvert[im, "Grayscale"], rim6]


One can apply here a smooth threshold with the criterion $$r + b > \alpha g.$$

ImageApply[With[{t = (1 + Tanh[2 (1.5 #[[2]] - #[[1]] - #[[3]])])/2}, # t +
Mean[#] {1, 1, 1} (1 - t)] &, im]


The same with packed arrays:

Image@Transpose[#, {3, 1, 2}] &@
With[{t = (1 + Tanh[2 (1.5 #2 - # - #3)])/
2}, {# t, #2 t, #3 t} +
ConstantArray[(1 - t) Mean@{##}, 3]] & @@
Transpose[#, {2, 3, 1}] &@ImageData@im


It is only 30% faster. I thing it is due to auto-compilation in ImageApply.

A darker version, which is closer to real-life black tulips:

With[{t = (1 - Tanh[4 (#[[1]] - #[[2]] - 0.5 #[[3]])])/2}, # t +
0.2 Mean[#] {1, 1, 1} (1 - t)] &, im]


• wow. Those are believable in color. +1 Sep 17 '14 at 12:47
• How did you come up with the Tanh function? I'm by no means am image processing expert, but that can't be just a trial-and-error function... (+1 BTW)
– kale
Sep 17 '14 at 13:25
• @kale It is one of simple functions which gives a smooth version of UnitStep. Others are ArcTan, Erf, etc. Furthermore, these functions allow to construct a smooth version of TriangleWave and so on. Sep 17 '14 at 13:48
• You could apply a mask for letting the leaves untouched. Something like Opening[Binarize@ ColorReplace[ColorSeparate[im, "HSB"][[1]], Black -> White, .003], 3] Sep 17 '14 at 14:25