Identifying and removing features from scanned handwriten text

Question

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

Answer 1

Almost!

Convert your image to binary image

img = Import["https://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 &]

Contrasting your image with after.

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

Answer 2

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:

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

3. 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......

Hope this can help you~

---

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.

Answer 3

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["https://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 )