Split up word pairs in string based on semantic textual analysis

Question

I have several hundred sentence-strings with joined words. They were extracted from a text (and are in sequence).

Here is an example of one:

"thequick brown foxjumped over the lazydog"

I would like to be able to split up joined "word pairs":

"the quick brown fox jumped over the lazy dog"

How would one approach implementing such an operation in mathematica? Ideas welcome!

Answer 1

This is not really a solution, but a quick demonstration of trying to solve this problem with neural networks.

My approach is to take small snippets of text (ending up as fixed-size input) from a corpus, mangling them by removing varying amount of spaces from some (or no!) locations, and to train the neural network to recognise if a space is missing at a specific offset of the sample string. (In my case, 16-letter inputs and looking on the offset 8 of the string.) This approach doesn't use recurrent neural networks or anything fancy, just a list of letters as input and a single output; here it's a "Real" for visualization purposes, but it could also be a "Boolean" with help of NetDecoder very easily.

The bulk of code is in the snippet mangling part. It may be a bit messy, but it does basically what I described above. I use Darwin's (On) the Origin of Species as my corpus (a toy approach!), since it's easily available on Mathematica, in a clean format, and it isn't too archaic or way too short for the purpose. The following creates the training set and trains a small network:

ClearAll[trainednet, extractlength, position];

extractlength = 16;
position = 8;
trainednet = 
  With[{corpus = ExampleData[{"Text", "OriginOfSpecies"}], 
    size = 2000000},
   With[{trainingset = 
      With[{omits = 
             Sort@RandomSample[StringPosition[#, " "], 
               UpTo@RandomVariate[
                 BinomialDistribution[extractlength, 
                  2/extractlength]]]}, 
           StringTake[StringReplacePart[#, "", omits], 
             extractlength] -> 
            Boole@MemberQ[omits[[All, 1]] - Range@Length@omits + 1, 
              position]] &@
         StringTake[corpus, {#, # + 2 extractlength}] & /@ 
       RandomInteger[{1, StringLength@corpus - 2 extractlength}, 
        size], net = 
      NetChain[{UnitVectorLayer[], LinearLayer[512], LinearLayer[128],
         LinearLayer[32], SoftmaxLayer[], LinearLayer[]}, "Input" ->
        NetEncoder[{"Characters", "TargetLength" -> extractlength, 
          IgnoreCase -> True}], "Output" -> "Real"]},
    NetTrain[net, trainingset, BatchSize -> 4096, 
     MaxTrainingRounds -> 60, ValidationSet -> Scaled[0.1]]]];

This takes about an hour on my CPUs. Now I can define a function to visualize weights the network gives to adding a space ahead of a specific letter on the input:

ClearAll@missingspacevisualize; 

missingspacevisualize[str_String] := 
 BarChart@Table[
     Labeled[trainednet[StringTake[#, {i, i + extractlength}]], 
      StringTake[#, {i, i} + position - 1]], {i, 
      StringLength@# - extractlength}] &@
  StringJoin[StringRepeat[" ", extractlength - position - 1], str, 
   StringRepeat[" ", extractlength - position + 1]];

Now, my own example that demonstrates that the network is not all bull!

missingspacevisualize[
 "this sentenceis unfortunately not verywell written, I know inthis case"]

Well, that wasn't so bad for a dumb set of tensor algebra! Well, how does it perform with the string in the question? With a sufficiently long training run it does perform surprisingly well!

missingspacevisualize["thequick brown foxjumped over the lazydog"]

This is not a global matching algorithm like my earlier answer to a similar problem (https://mathematica.stackexchange.com/a/119905/3056). So, how does this implementation perform in comparison to that one?

missingspacevisualize["tableapplecharitablecupboarding"]

Well, surprisingly poorly. I guess the network more and more expects long words to just go on with longer and longer training times. Surely that's not a typical "some spaces omitted" input.

Answer 2

I didn't check for speed, but one possibility is:

splitWord[s_] := If[DictionaryWordQ[s],
    s<>" ",
    StringReplaceList[
        s,
        StartOfString~~a__~~b__~~EndOfString /; AllTrue[{a,b}, DictionaryWordQ] :> a<>" "<>b<>" "
    ] /. {a_} :> a
]

Then:

splitWord["thequick"]
splitWord["carseat"]

"the quick "

{"cars eat ", "car seat "}

For your example:

words = splitWord /@ StringSplit @ "thequick brown foxjumped over the lazydog"

{"the quick ", "brown ", "fox jumped ", "over ", "the ", "lazy dog "}

Since there were no ambiguous splits, you can just StringJoin the output:

StringJoin[words]

"the quick brown fox jumped over the lazy dog "

If there were ambiguous splits, then perhaps you can use a function like TextStructure to choose the words that make the most grammatical sense.