# Identifying and removing features from scanned handwriten text

Please, can I have some ideas and help on how to identify and remove features like this one or this one from scanned handwritten text like this: These features are not connected to other text elements (letters), they are always similar to this two examples, and they are oriented with slight variation (up to +/-10 degrees). They are always below letters. In this example there are 12 such features (4,6,2 in rows 1,2,3).

• Since this is an image processing problem, you need to supply the complete image. Otherwise, there's no way to know how to remove those artifacts: we can't know if you can just remove a color, or if you have to identify shapes, etc. Also: be a little more clear what you need. Do you need to remove those specific images, or do you need to remove splotches that are generally that shape and are generally purple like that? – march Jun 23 '16 at 19:57

Almost!

Convert your image to binary image

img = Import["http://i.stack.imgur.com/uRUEw.jpg"];
binimg = ColorNegate@Binarize[img, .75]


Get tha mask used in Inpaint

mask = SelectComponents[binimg, {"PerimeterLength", "Elongation"},
60 < # < 160 || #2 > 0.8 &]


Grid[{{"Before", Magnify[img, 5]}, {"After",Magnify[Inpaint[img, Dilation[mask, 1],
Method -> "TextureSynthesis"], 5]}}]


• this aproach is useful for me, but I have little problem with function construction. Please help for implementing MinimalBoundingBox measure in this: Needs["Developer"]; SelectComponents[ someimage , {"MinimalBoundingBox"} , 11 > Min@ PartitionMap[ EuclideanDistance[_SOME _CODE _HERE _] &, #1[[1 ;; 3]], 2, 1] & ] – Dragutin Jul 5 '16 at 15:04

# Hey, go to upvote @yode's answer! He's brilliant!

Result first, I hope that would be good enough:

The idea is quite simple------Find those feature and try to delete them.

# How to use the code?

1. Manually select the features you would like to delete, binarize it properly and put it in ker. For example, at this place you could use something like this:

1. If you want a better result, create another mask and roughly single out all the words. Create a mask like this and put it in msk1:

1. run the code and get the result.

# Code

Inpaint[imgo,
Binarize[ColorSeparate[
HighlightImage[
imgo, {Red, Opacity@1,
Disk[#, 20] & /@
ImageCorners@
Binarize[
ImageCorrelate[
ImageMultiply[ColorNegate@Binarize@imgo, ColorNegate@msk1],
ker, Mean@Abs@Flatten[#1 - #2] &], .2]}], "R"], .95]]


# How it works

1. Firstly and most importantly, it will do a ImageCorrelate and find the points with good fit to ker.

2. Then it will find out those points in need of delete process by using ImageCorners

3. Finally, we can use Inpaint to get a desired result.

# Places that can be further improved

1. The sign MUST BE almost EXACTLY the same. longer or shorter will influence the detection process and some extra mark in detection area will also interfere with result. Also, sometimes it will mis-detect the down part of "o" if you don't make the mask carefully.

2. Speed is quite slow......

# Edit 1

This edit's main(maybe I should not say "main", it totally is!) contributor is @yode. Without his help, this code will still need a stupid mask.......

Now this answer can correct the image at higher accuracy and have higher detection rate.

The result is like this~

This code requires only imgo and ker:

Inpaint[imgo,
Binarize[ColorSeparate[
HighlightImage[
imgo, {Red, Opacity@1,
Disk[#, 20] & /@
ImageCorners@
Binarize[
ImageCorrelate[
SelectComponents[ColorNegate@Binarize@imgo,
"PerimeterLength", 40 < # < 200 &], ker,
Mean@Abs@Flatten[#1 - #2] &], .2]}], "R"], .95]]


BTW: @yode is on his way to post a much more elegant, faster and wider appliable answer.

• Thank you for reply. This procedures are very useful for me, and it will find place in my image manipulations. :) But unfortunately, in this example, this does not lead to satisfying results. my run without mask, leads to following result resultimage The reasons are: 1) I'm unable to create masks msk1, because, there are too much variations of row spacings, and row heights, in texts. 2) it is impossible to create all variations of shaper in ker – Dragutin Jun 26 '16 at 17:33
• I hope that this can be solved with topological and geometrical search of objects of desired shape across the image. But I have no idea how to start and which functions can be appropriate in this application. – Dragutin Jun 26 '16 at 17:33
• msk1 needn't be created with much care. Just use the drawing tools in Mathematica and There'll be a suggestion bar telling you how to create a mask. This act is simply for removing some unnecessary mis-detection. And for your second question, I think it's quite hard and the only way to do so is by adding more and more ker image by geometrical transforming our orignal ker. It it quite hard and needs extra time...... – Wjx Jun 27 '16 at 0:54
• maybe I'll add something to automatically create this mask sometime later. – Wjx Jun 27 '16 at 0:58

Thank @Wjx, and especially @yode for idea. I refined selector conditions a bit. I built function that check angle of feature from it's MinimalBoundingBox. Also elongation is calculated from MinimalBoundingBox. There are also linear constraints, as two line inequalities, that restricts elongation and one of MinimalBoundingBox sides.

imx = Import["http://i.stack.imgur.com/uRUEw.jpg"]
angle = 25;
perlen = {35, 230};

checkangle=(If[!
Chop[Abs@{#[[1,1]]-#[[2,1]],#[[1,2]]-#[[2,2]]} -
Reverse[Abs@{#[[2,1]]-#[[3,1]],#[[2,2]]-#[[3,2]]}],
10^-6]==={0,0}
, If[
EuclideanDistance[{#[[1,1]],#[[1,2]]},{#[[2,1]],#[[2,2]]}] >
EuclideanDistance[{#[[3,1]],#[[3,2]]},{#[[2,1]],#[[2,2]]}]
,N@#/Degree&@ArcTan[Abs[#[[2,1]]-#[[1,1]]],Abs[#[[2,2]]-#[[1,2]]]]
,N@#/Degree&@ArcTan[Abs[#[[2,1]]-#[[3,1]]],Abs[#[[2,2]]-#[[3,2]]]]
] < angle
, False
] &@N@{{#[[1,1]],#[[1,2]]},{#[[2,1]],#[[2,2]]},{#[[3,1]],#[[3,2]]}}) &;

Inpaint[imx
, Dilation[
SelectComponents[
(ColorNegate@Binarize[imx, .8])
, {"MinimalBoundingBox", "PerimeterLength"}
, perlen[[1]] < #2 < perlen[[2]]
&& checkangle@#1
&& Function[{e,
x}, ! (((x < -16.8 + 80*e) && (x > 69 - 50*e)) || (e <
0.2))] @@ (Function[{y, x}, {1 - y/x, x}] @@ (Sequence @@@
Sort[EuclideanDistance @@@
Partition[#1[[1 ;; 3]], 2, 1]])) &
], 1]
, Method -> "TextureSynthesis"
]


The result is:

( by the way, I would like to replace Function[{y,x}, {1-y/x,x}]` with pure function )