How to speed up text recognition

Question

I have a large corpus of text to analyse. I've managed to automate splitting it into individual lines because I've found that each line in this relatively old scanned document needs to be dealt with subtly differently because of the difference in clarity of the lines.

I've found that a good way to alter the lines to get the best character recognition is to use Binarize with different thresholds for the binarization. For example, here is a line of text:

I import this:

Import["image.jpg"]

and then create a table of different binarizations (I tried with a similar method with ImageAdjust but this involved looping over three variables with multiple values: {c,b,\[Gamma]} in the ImageAdjust options):

binarized=Binarize[image,#]&/@Range[0.45,0.95,0.025]

I've found that this is the range and fineness of the thresholds needed to get a good fidelity from the readings of different lines.

textrec=TextRecognize[#]&/@binarized

This in itself takes rather a long time and outputs everything from:

(*
 Output==>{"~'»ur1f'lf+ lilfv :\\ '¢f\\1f'~u\\r1 \\-f-'._\\_' _-\\11~<r.r"}
*)

to

(*
 Output==>{"All this sounds like a. solemn vow! Anyone hear-"}
*)

I then take this and split it into individual words, removing punctuation and a few other strings:

ssplit=StringSplit[#,("\""|"?"|"["|"\[OpenCurlyDoubleQuote]"|","| 
 "."|"\[CloseCurlyDoubleQuote]"|"'s"|"\[CloseCurlyQuote]s"|"'"|"]"|"'"|"!"|" ")]&/@textrec

I then take this and check each binarization of the line in the dictionary, asking how many total words are in the dictionary (The DictionaryLookup also takes a long time):

With[{x=DeleteCases[(DictionaryLookup[#,IgnoreCase->True]&/@#),{}]},{Length[x],x}]&/@ssplit

This gives an output like the following (first element is the number of words found in the dictionary, second element is the list of words found in the dictionary:

{{1, {{"I"}}}, 
 {1, {{"I"}}}, 
 {0, {}}, 
 {0, {}}, 
 {0, {}}, 
 {1, {{"huh"}}}, 
 {4, {{"all"}, {"this"}, {"sounds"}, {"like"}}}, 
 {5, {{"all"}, {"this"}, {"sounds"}, {"like"}, {"anyone"}}}, 
 {4, {{"all"}, {"this"}, {"sounds"}, {"like"}}}, 
 {4, {{"all"}, {"this"}, {"like"}, {"a"}}},  
 {6, {{"all"}, {"this"}, {"like"}, {"a"}, {"vow"}, {"anyone"}}}, 
 {5, {{"all"}, {"this"}, {"like"}, {"a"}, {"anyone"}}},  
 {5, {{"all"}, {"this"}, {"like"}, {"a"}, {"anyone"}}}, 
 {5, {{"all"}, {"this"}, {"like"}, {"a"}, {"anyone"}}}, 
 {6, {{"all"}, {"this"}, {"sounds"}, {"like"}, {"a"}, {"anyone"}}}, 
 {8, {{"all"}, {"this"}, {"sounds"}, {"like"}, {"a"}, {"solemn"}, {"vow"},{"anyone"}}}, 
 {6, {{"all"}, {"this"}, {"sounds"}, {"like"}, {"a"}, {"anyone"}}}, 
 {8, {{"all"}, {"this"}, {"sounds"}, {"like"}, {"a"}, {"solemn"}, {"vow"},{"anyone"}}}, 
 {6, {{"all"}, {"this"}, {"like"}, {"a"}, {"solemn"}, {"anyone"}}}, 
 {0, {}}, 
 {0, {}}}

So you can see that there is a value for the binarization threshold which gives all of the words as words in the dictionary. The last word is a half word and this is solved in another way.

The question (and my apologies for the length if this question) is whether anyone can find a way to speed up this process. Each document has a hundred or so lines and I will have a lot of documents to go through. Any advice would be gratefully received.

I have found a way to fix words which are not found in the dictionary (ie. not correctly recognized by TextRecognize using some contextual analysis, but that may warrant another question another time)

Belisarius has asked me to add a few more lines of text, so here they are. They are direct from the document, so you can see the variance in line contrast and darkness:

Nothing political should be read into this :-)

Edit:

I was also asked to explain how I split the text up into lines. It is not elegant by any means and if someone else has a nicer way to code this, I would love to see it.

The particular image that I'm using for this example can be found here.

Import the image and take its dimensions:

img=Import["image1.jpg"]
dims=ImageDimensions[img]

In this example the format is two column, so I pull out the left and right. I'll focus entirely here on the left:

imgl=ImageTake[img,{1,dims[[2]]},{1,Round[dims[[1]]/2]}];

This will take the n^th line from the image:

itl[n_]:=ImageTake[imgl,{n,n}]

Now we go through all the lines and find those which have less than ten pixels with brightness less than 200. This will give a list of all the lines which are not blank.

rowsl=Position[If[Length[Select[ImageData[itl[#],"Byte"][[1,;;,1]],#<200 &]]<10, 
blank,itl[#]]&/@Range[dims[[2]]],Except[blank]]//Flatten

Now we go through the list of all the non-white lines and find the differences between these line numbers. If the difference is more than 3 pixels we treat it as part of a white space between text lines:

valsl=Position[Differences[rowsl],Except[1|2|3]][[2;;]]//Flatten

This will take the information from the white space regions and find the regions which are not white, ie. lines of text

trythesel=Partition[Riffle[valsl,valsl+Table[1,{n,Length[valsl]}]][[2;;]],2];

Take 3 pixels above and 3 pixels below the lines of non-blank that have been found:

linesl={rowsl[[#[[1]]]]-3,rowsl[[#[[2]]]]+3}&/@trythesel;

We can then pull out the n^th line of text by using:

nthline=ImageCrop[ImageTake[imgl,linesl[[n]]]]

Answer 1

Using undocumented TextRecognize options as you can see here, you can do:

create a textLinesImg like this:

Manipulate[
 Column[TextRecognize[Binarize[#, b], "SegmentationMode" -> 7] & /@ 
   textLinesImg]
 , {{b, 0.9}, 0, 1}
 , ContinuousAction -> False
 ]