diff --git a/chatter.cabal b/chatter.cabal --- a/chatter.cabal +++ b/chatter.cabal @@ -1,5 +1,5 @@ name: chatter -version: 0.2.0.0 +version: 0.2.0.1 synopsis: A library of simple NLP algorithms. description: chatter is a collection of simple Natural Language Processing algorithms. @@ -48,6 +48,7 @@ NLP.Corpora.Email NLP.Similarity.VectorSim NLP.Extraction.Parsec + NLP.Extraction.Examples.ParsecExamples Data.DefaultMap Build-depends: base >= 4 && <= 6, @@ -160,6 +161,7 @@ Data.DefaultMapTests Corpora TestUtils + IntegrationTests Build-depends: chatter, base >= 4 && <= 6, diff --git a/data/models/brown-train.model.gz b/data/models/brown-train.model.gz # file too large to diff: data/models/brown-train.model.gz diff --git a/src/NLP/Extraction/Examples/ParsecExamples.hs b/src/NLP/Extraction/Examples/ParsecExamples.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Extraction/Examples/ParsecExamples.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module NLP.Extraction.Examples.ParsecExamples where + +import qualified Data.Text as T +import Data.Text (Text) + +import Text.Parsec.Prim (parse, (<|>), try) +import Text.Parsec.Pos +import qualified Text.Parsec.Combinator as PC + +import NLP.Types +import NLP.Extraction.Parsec + +-- grammar = r""" +-- NP: {+} # Chunk sequences of DT, JJ, NN +-- PP: {} # Chunk prepositions followed by NP +-- VP: {+$} # Chunk verbs and their arguments +-- CLAUSE: {} # Chunk NP, VP +-- """ +-- cp = nltk.RegexpParser(grammar) +-- sentence = [("Mary", "NN"), ("saw", "VBD"), ("the", "DT"), ("cat", "NN"), +-- ("sit", "VB"), ("on", "IN"), ("the", "DT"), ("mat", "NN")] + + +-- | Create a chunked tag from a set of incomming tagged tokens. +chunk :: [(Text, Tag)] -- ^ The incomming tokens to create a chunk from. + -> Tag -- ^ The tag for the chunk. + -> (Text, Tag) +chunk tss tg = (T.unwords (map fst tss), tg) + +prepPhrase :: Extractor (Text, Tag) +prepPhrase = do + prep <- posTok $ Tag "IN" + np <- nounPhrase + return $ chunk [prep, np] (Tag "p-phr") + +nounPhrase :: Extractor (Text, Tag) +nounPhrase = do + nlist <- PC.many1 (try (posTok $ Tag "NN") + <|> try (posTok $ Tag "DT") + <|> (posTok $ Tag "JJ")) + let term = T.intercalate " " (map fst nlist) + return (term, Tag "n-phr") + +clause :: Extractor (Text, Tag) +clause = do + np <- nounPhrase + vp <- verbPhrase + return $ chunk [np, vp] $ Tag "clause" + +-- VP: {+$} # Chunk verbs and their arguments +-- CLAUSE: {} +verbPhrase :: Extractor (Text, Tag) +verbPhrase = do + vp <- posPrefix "V" + obj <- PC.many1 $ ((try nounPhrase) + <|> (try prepPhrase) + <|> clause) + return $ chunk (vp:obj) $ Tag "v-phr" diff --git a/src/NLP/Extraction/Parsec.hs b/src/NLP/Extraction/Parsec.hs --- a/src/NLP/Extraction/Parsec.hs +++ b/src/NLP/Extraction/Parsec.hs @@ -11,9 +11,9 @@ -- @ -- nounPhrase :: Extractor (Text, Tag) -- nounPhrase = do --- nlist <- many1 (try (posTok $ Tag "NN") --- <|> try (posTok $ Tag "DT") --- <|> (posTok $ Tag "JJ")) +-- nlist <- many1 (try (posTok $ Tag \"NN\") +-- \<|\> try (posTok $ Tag \"DT\") +-- \<|\> (posTok $ Tag \"JJ\")) -- let term = T.intercalate " " (map fst nlist) -- return (term, Tag "n-phr") -- @ @@ -36,10 +36,12 @@ -- | A Parsec parser. -- -- Example usage: +-- +-- @ -- > set -XOverloadedStrings -- > import Text.Parsec.Prim -- > parse myExtractor "interactive repl" someTaggedSentence --- +-- @ type Extractor = Parsec TaggedSentence () -- | Consume a token with the given POS Tag @@ -52,9 +54,10 @@ -- | Consume a token with the specified POS prefix. -- +-- @ -- > parse (posPrefix "n") "ghci" [("Bob", Tag "np")] -- Right [("Bob", Tag "np")] --- +-- @ posPrefix :: Text -> Extractor (Text, Tag) posPrefix str = token showTok posFromTok testTok where diff --git a/src/NLP/POS.hs b/src/NLP/POS.hs --- a/src/NLP/POS.hs +++ b/src/NLP/POS.hs @@ -208,7 +208,6 @@ Just b -> do tgr <- train b exs return $ Just tgr trainer = posTrainer p - putStrLn ("train - exs: "++show exs) newTgr <- trainer exs newBackoff <- trainBackoff return (newTgr { posBackoff = newBackoff }) diff --git a/src/NLP/POS/LiteralTagger.hs b/src/NLP/POS/LiteralTagger.hs --- a/src/NLP/POS/LiteralTagger.hs +++ b/src/NLP/POS/LiteralTagger.hs @@ -60,12 +60,25 @@ Sensitive -> id Insensitive -> Map.mapKeys T.toLower +escapeRegexChars :: Text -> Text +escapeRegexChars input = helper [ "\\", ".", "+", "*", "?", "[", "^", "]", "$" + , "(", ")", "{", "}", "=", "!", "<", ">", "|" + , ":", "-" + ] input + where + helper :: [Text] -> Text -> Text + helper [] term = term + helper (x:xs) term = helper xs $ escapeChar x term + + escapeChar :: Text -> Text -> Text + escapeChar char term = T.replace char (T.append "\\" char) term + -- | Create a tokenizer that protects the provided terms (to tokenize -- multi-word terms) protectTerms :: [Text] -> CaseSensitive -> Tokenizer protectTerms terms sensitive = - let sorted = sortBy (compare `on` T.length) terms + let sorted = sortBy (compare `on` T.length) $ map escapeRegexChars terms sensitivity = case sensitive of Insensitive -> False @@ -81,7 +94,8 @@ execOption = ExecOption { captureGroups = False } - eRegex = compile compOption execOption (T.concat ["\\<", (T.intercalate "\\>|\\<" sorted), "\\>"]) + eRegex = compile compOption execOption + (T.concat ["\\<", (T.intercalate "\\>|\\<" sorted), "\\>"]) toEithers :: [(Int, Int)] -> Text -> [Either Text Text] toEithers [] str = [Right str] diff --git a/src/NLP/POS/UnambiguousTagger.hs b/src/NLP/POS/UnambiguousTagger.hs --- a/src/NLP/POS/UnambiguousTagger.hs +++ b/src/NLP/POS/UnambiguousTagger.hs @@ -17,6 +17,7 @@ import Data.Serialize (encode, decode) import Data.Text (Text) +import NLP.Tokenize.Text (defaultTokenizer, run) import NLP.Types import qualified NLP.POS.LiteralTagger as LT @@ -38,14 +39,12 @@ trainer :: [TaggedSentence] -> IO POSTagger trainer exs = do let newTable = train table exs - putStrLn ("exs: "++show exs) - putStrLn ("table: "++show table) - putStrLn ("new table: "++show newTable) return $ mkTagger newTable mTgr in litTagger { posTrainer = trainer , posSerialize = encode table , posID = taggerID + , posTokenizer = run defaultTokenizer } -- | Trainer method for unambiguous taggers. diff --git a/tests/src/IntegrationTests.hs b/tests/src/IntegrationTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/IntegrationTests.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +module IntegrationTests + +where + +---------------------------------------------------------------------- +import Test.QuickCheck ( Arbitrary, arbitrary, (==>), Property + , NonEmptyList(..), listOf) +import Test.QuickCheck.Instances () +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework ( testGroup, Test, buildTest ) +import Test.HUnit ( (@=?), Assertion, assertFailure, assertEqual ) +---------------------------------------------------------------------- +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Map as Map +import Text.Parsec.Prim (parse, (<|>), try) +import Text.Parsec.Pos +import qualified Text.Parsec.Combinator as PC +---------------------------------------------------------------------- +import NLP.Types +import NLP.POS +import NLP.Corpora.Parsing +import NLP.Extraction.Parsec +import NLP.Extraction.Examples.ParsecExamples + +import qualified NLP.POS.AvgPerceptronTagger as Avg +import qualified NLP.POS.LiteralTagger as LT +import qualified NLP.POS.UnambiguousTagger as UT + +import TestUtils + +tests :: Test +tests = buildTest $ do + tagger <- defaultTagger + return $ testGroup "Integration Tests" + [ testGroup "Default Tagger" $ + map (genTest $ tagText tagger) + [ ("Simple 1", "The dog jumped.", "The/at dog/nn jumped/vbd ./.") + ] + , testGroup "POS Serialization" $ + map (testSerialization examples) + [ ("Average Perceptron", Avg.mkTagger Avg.emptyPerceptron Nothing) + , ("Unambiguous", UT.mkTagger Map.empty Nothing) + , ("Literal", LT.mkTagger Map.empty Sensitive Nothing) + , ("Unambiguous -> Avg" + , UT.mkTagger Map.empty + (Just $ Avg.mkTagger Avg.emptyPerceptron Nothing)) + ] + ] + + +examples :: [Text] +examples = [ "This/dt is/bez a/at test/nn ./." + , "The/at dog/nn jumped/vbd over/in the/at cat/nn ./." + , "Where/wrb is/bez the/at conference/nn ?/." + ] + +testSerialization :: [Text] -- ^ A training corpus. One sentence per entry. + -> ( String -- ^ The name of the POS tagger. + , POSTagger) -- ^ An empty (untrained) POS tagger. + -> Test +testSerialization training (name, newTagger) = testCase name doTest + where + doTest :: Assertion + doTest = do + preTagger <- train newTagger $ map readPOS training + + let ePostTagger = deserialize taggerTable (serialize preTagger) + case ePostTagger of + Left err -> assertFailure ("Tagger did not deserialize: "++err) + Right postTagger -> do + let pre = map (tagText preTagger) training + post = map (tagText postTagger) training + assertEqual "Taggers tagged differently" pre post diff --git a/tests/src/Main.hs b/tests/src/Main.hs --- a/tests/src/Main.hs +++ b/tests/src/Main.hs @@ -27,6 +27,7 @@ import qualified NLP.TypesTests as TypeTests import qualified Data.DefaultMapTests as DefMap import qualified NLP.Extraction.ParsecTests as Parsec +import qualified IntegrationTests as IT import Corpora @@ -65,6 +66,7 @@ , TypeTests.tests , DefMap.tests , Parsec.tests + , IT.tests ] diff --git a/tests/src/NLP/Extraction/ParsecTests.hs b/tests/src/NLP/Extraction/ParsecTests.hs --- a/tests/src/NLP/Extraction/ParsecTests.hs +++ b/tests/src/NLP/Extraction/ParsecTests.hs @@ -19,6 +19,7 @@ ---------------------------------------------------------------------- import NLP.Types import NLP.Extraction.Parsec +import NLP.Extraction.Examples.ParsecExamples import TestUtils @@ -73,14 +74,6 @@ (taggedSent ++ [(theToken, theTag)]) in (theToken, theTag) == actual - -nounPhrase :: Extractor (Text, Tag) -nounPhrase = do - nlist <- PC.many1 (try (posTok $ Tag "NN") - <|> try (posTok $ Tag "DT") - <|> (posTok $ Tag "JJ")) - let term = T.intercalate " " (map fst nlist) - return (term, Tag "n-phr") parseNounPhrase :: TaggedSentence -> Maybe (Text, Tag) parseNounPhrase sent =