Perform Typo Correction without a Dictionary 

Modeling the sequence of typed characters as observations and the sequence of the correct characters as hidden states, this example uses two different models for the evolution of correct letters to correct for typos. The first model uses the first-order Markov process to encode frequencies of what follows the given character. The second model uses the second-order Markov states to encode frequencies of what follows the given last two characters.

Take Darwin’s The Origin of Species and convert all non-letter symbols to spaces.

In[1]:=

X oosText = ToLowerCase[ StringReplace[ExampleData[{"Text", "OriginOfSpecies"}], Except[LetterCharacter] .. -> Space]]; oosLen = StringLength[oosText];

In[2]:=

X chars = Append[CharacterRange["a", "z"], Space]; charsLen = Length[chars];

Introduce typos, at a 20% rate, by randomly replacing a character with one of its immediate neighbors on the standard QWERTY keyboard. The space character is never mistyped.

show complete Wolfram Language inputhide input

In[3]:=

X typoRules = {"a" :> RandomChoice[{"q", "w", "s", "z"}], "b" :> RandomChoice[{"v", "g", "h", "n"}], "c" :> RandomChoice[{"x", "d", "f", "v"}], "d" :> RandomChoice[{"x", "s", "e", "r", "f", "c"}], "e" :> RandomChoice[{"w", "s", "d", "r"}], "f" :> RandomChoice[{"c", "d", "r", "t", "g", "v"}], "g" :> RandomChoice[{"v", "f", "t", "y", "h", "b"}], "h" :> RandomChoice[{"b", "g", "y", "u", "j", "n"}], "i" :> RandomChoice[{"u", "j", "k", "o"}], "j" :> RandomChoice[{"n", "h", "u", "i", "k", "m"}], "k" :> RandomChoice[{"m", "j", "i", "o", "l"}], "l" :> RandomChoice[{"k", "o", "p"}], "m" :> RandomChoice[{"n", "j", "k"}], "n" :> RandomChoice[{"b", "h", "j", "m"}], "o" :> RandomChoice[{"i", "k", "l", "p"}], "p" :> RandomChoice[{"o", "l"}], "q" :> RandomChoice[{"w", "a"}], "r" :> RandomChoice[{"e", "d", "f", "t"}], "s" :> RandomChoice[{"z", "a", "w", "e", "d", "x"}], "t" :> RandomChoice[{"r", "f", "g", "y"}], "u" :> RandomChoice[{"y", "h", "j", "i"}], "v" :> RandomChoice[{"c", "f", "g", "b"}], "w" :> RandomChoice[{"q", "a", "s", "e"}], "x" :> RandomChoice[{"z", "s", "d", "c"}], "y" :> RandomChoice[{"t", "g", "h", "u"}], "z" :> RandomChoice[{"a", "s", "x"}]};

In[4]:=

X typoProb = 0.20; BlockRandom[ SeedRandom["Mathematica10"]; typosMask = RandomChoice[{1 - typoProb, typoProb} -> Range[0, 1], oosLen]; typosSeq = Pick[Characters[oosText], typosMask, 1] /. typoRules; ]

In[5]:=

X oosTextWithTypos = StringJoin[ReplacePart[Characters[oosText], MapThread[Rule, {Pick[Range[oosLen], typosMask, 1], typosSeq}]] ];

show complete Wolfram Language inputhide input

In[6]:=

X Grid[{{Style["Original text", Larger, Bold], Style["Text with typos", Larger, Bold]}, {Pane[ StringTake[oosText, 200], 250], Pane[StringTake[oosTextWithTypos, 200], 250]}}, Dividers -> {{2 -> Black}, {2 -> Black}}]

Out[6]=

Take the first 80,000 characters to be a test sequence, and the remainder of the text as a training sequence. The test sequence has 16.5% mistyped characters, less than 20% because the space character was never mistyped.

In[7]:=

X testLen = 80000; Count[Thread[{Characters[StringTake[oosText, testLen]], Characters[StringTake[oosTextWithTypos, testLen]]}], {a_, b_} /; a =!= b]/testLen // N

Out[7]=

Model the stream of typed characters using hidden Markov process. Correct characters are hidden states, while the actual typed characters are observations.

In[8]:=

X intMapRule = Dispatch[Thread[chars -> Range[charsLen]]]; trainingStates = Characters[StringDrop[oosText, testLen]] /. intMapRule; trainingObs = Characters[StringDrop[oosTextWithTypos, testLen]] /. intMapRule;

Estimate the hidden Markov process using training data.

In[9]:=

X AbsoluteTiming[ estHMM1 = EstimatedProcess[trainingObs, HiddenMarkovProcess[charsLen, charsLen], ProcessEstimator -> {"SupervisedTraining", "StateData" -> trainingStates}];]

Out[9]=

In[10]:=

X estHMM1 = ReplacePart[ estHMM1, {2 -> estHMM1[[2]] (1 - 1/(oosLen - testLen)) + 1/(oosLen - testLen) ConstantArray[ 1./charsLen, {charsLen, charsLen}], 1 -> ConstantArray[1./charsLen, charsLen]}];

Use posterior decoding to correct typos in the test portion of the mistyped text.

In[11]:=

X AbsoluteTiming[ ppath = FindHiddenMarkovStates[ Characters[StringTake[oosTextWithTypos, testLen]] /. intMapRule, estHMM1, "PosteriorDecoding"];]

Out[11]=

Corrected text still has 11% typos, 5.5% fewer than the original typed text.

show complete Wolfram Language inputhide input

In[12]:=

X Grid[{{Style["Text with typos", Larger, Bold], Style["Typo-corrected text", Larger, Bold]}, {Pane[ StringTake[oosTextWithTypos, 200], 250], Pane[StringJoin[ Take[ppath, 200] /. Reverse[Normal[intMapRule], 2]], 250]}}, Dividers -> {{2 -> Black}, {2 -> Black}}]

Out[12]=

In[13]:=

X Count[Thread[{Characters[StringTake[oosText, testLen]], ppath /. Reverse[Normal[intMapRule], 2]}], {a_, b_} /; a =!= b]/ testLen // N

Out[13]=

Model evolution of the hidden states using a second-order Markov process; i.e. assume the probability of the character depends only on the two preceding characters. The second-order Markov process is modeled as a first-order Markov process with enlarged state space of pairs of consecutive characters.

In[14]:=

X pairsIntMap = Dispatch[Thread[ Tuples[Range[charsLen], 2] -> Range[charsLen^2]]]; trainingPairs = Partition[trainingStates, 2, 1] /. pairsIntMap; trainingEmissionsPerPair = Rest[trainingObs];

In[15]:=

X p0 = ConstantArray[1./charsLen^2, charsLen^2]; tm = N[#/Total[#]] & /@ Normal[1/(oosLen - testLen) + SparseArray[Rule @@@ Tally[Partition[trainingPairs, 2, 1]], charsLen^2 {1, 1}]];

The probability of the actual typed character depends only on the underlying true character.

In[16]:=

X hmm2 = HiddenMarkovProcess[p0, tm, Join @@ Table[estHMM1[[3]], {charsLen}]];

Repeat posterior decoding with the higher-order hidden Markov model.

In[17]:=

X AbsoluteTiming[ ppath2 = FindHiddenMarkovStates[ Characters[StringTake[oosTextWithTypos, testLen]] /. intMapRule, hmm2, "PosteriorDecoding"];]

Out[17]=

The percentage of typos has now been reduced to under 6%.

In[18]:=

X Count[Thread[{Characters[StringTake[oosText, testLen]] /. intMapRule, Part[ppath2 /. Reverse[Normal[pairsIntMap], 2], All, 2]}], {a_, b_} /; a =!= b]/testLen // N

Out[18]=

show complete Wolfram Language inputhide input

In[19]:=

X Grid[{{Style["Text with typos", Larger, Bold], Style["Typo-corrected text", Larger, Bold]}, {Pane[ StringTake[oosTextWithTypos, 200], 250], Pane[StringJoin[ Part[Take[ppath2, 200] /. Reverse[Normal[pairsIntMap], 2], All, -1] /. Reverse[Normal[intMapRule], 2]], 250]}}, Dividers -> {{2 -> Black}, {2 -> Black}}]

Out[19]=