diff --git a/appsrc/ChunkTrainer.hs b/appsrc/ChunkTrainer.hs new file mode 100644 --- /dev/null +++ b/appsrc/ChunkTrainer.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module ChunkTrainer where + +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.Environment (getArgs) + +import NLP.POS.AvgPerceptron (emptyPerceptron) +import qualified NLP.Chunk.AvgPerceptronChunker as Avg +import NLP.Chunk (train, saveChunker) +import NLP.Types.IOB + +import qualified NLP.Corpora.Conll as C + +main :: IO () +main = do + args <- getArgs + let output = last args + corpora = init args + + avgPerChunker :: Avg.Chunker C.Chunk C.Tag + avgPerChunker = Avg.mkChunker emptyPerceptron + + rawCorpus <- mapM T.readFile corpora + let eChunkedCorpora = parseIOB $ T.concat rawCorpus + case eChunkedCorpora of + Left err -> T.putStrLn err + Right chunkedCorpora -> do + chunker <- train avgPerChunker $ map toChunkTree chunkedCorpora + saveChunker chunker output + diff --git a/appsrc/POSTrainer.hs b/appsrc/POSTrainer.hs new file mode 100644 --- /dev/null +++ b/appsrc/POSTrainer.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +module POSTrainer where + +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.Environment (getArgs) + +import qualified NLP.POS.AvgPerceptronTagger as Avg +import qualified NLP.POS.UnambiguousTagger as UT +import NLP.POS (saveTagger, train) +import NLP.Types (POSTagger, Error) +import NLP.Types.IOB + +import qualified NLP.Corpora.Conll as C + +main :: IO () +main = do + args <- getArgs + let output = last args + corpora = init args + + avgPerTagger :: POSTagger C.Tag + avgPerTagger = Avg.mkTagger Avg.emptyPerceptron Nothing + + initTagger :: POSTagger C.Tag + initTagger = UT.mkTagger Map.empty (Just avgPerTagger) + rawCorpus <- mapM T.readFile corpora + let eCorpora :: Either Error [[IOBChunk C.Chunk C.Tag]] + eCorpora = parseIOB $ T.concat rawCorpus + case eCorpora of + Left err -> T.putStrLn err + Right taggedCorpora -> do + let taggedSentences = map toTaggedSentence taggedCorpora + tagger <- train initTagger taggedSentences + saveTagger tagger output + diff --git a/appsrc/Trainer.hs b/appsrc/Trainer.hs deleted file mode 100644 --- a/appsrc/Trainer.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Trainer where - -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.IO as T -import System.Environment (getArgs) - -import qualified NLP.POS.AvgPerceptronTagger as Avg -import qualified NLP.POS.UnambiguousTagger as UT -import NLP.POS (saveTagger, train) -import NLP.Corpora.Parsing -import NLP.Types (POSTagger) - -import qualified NLP.Corpora.Brown as B - -main :: IO () -main = do - args <- getArgs - let output = last args - corpora = init args - - avgPerTagger :: POSTagger B.Tag - avgPerTagger = Avg.mkTagger Avg.emptyPerceptron Nothing - - initTagger :: POSTagger B.Tag - initTagger = UT.mkTagger Map.empty (Just avgPerTagger) - rawCorpus <- mapM T.readFile corpora - let taggedCorpora = map readPOS $ concatMap T.lines $ rawCorpus - tagger <- train initTagger taggedCorpora - saveTagger tagger output - diff --git a/chatter.cabal b/chatter.cabal --- a/chatter.cabal +++ b/chatter.cabal @@ -1,5 +1,5 @@ name: chatter -version: 0.3.0.1 +version: 0.4.0.0 synopsis: A library of simple NLP algorithms. description: chatter is a collection of simple Natural Language Processing algorithms. @@ -27,7 +27,9 @@ Extra-Source-Files: changelog.md data-files: ./data/models/README - ./data/models/brown-train.model.gz + ./data/models/brown.pos.model.gz + ./data/models/conll2000.pos.model.gz + ./data/models/conll2000.chunk.model.gz source-repository head type: git @@ -44,14 +46,18 @@ NLP.POS.AvgPerceptronTagger NLP.POS.LiteralTagger NLP.POS.UnambiguousTagger + NLP.Chunk + NLP.Chunk.AvgPerceptronChunker NLP.Types NLP.Types.General + NLP.Types.IOB NLP.Types.Tags NLP.Types.Tree NLP.Tokenize.Chatter NLP.Corpora.Parsing NLP.Corpora.Email NLP.Corpora.Brown + NLP.Corpora.Conll NLP.Similarity.VectorSim NLP.Extraction.Parsec NLP.Extraction.Examples.ParsecExamples @@ -85,10 +91,10 @@ - ghc-options: -Wall + ghc-options: -Wall -auto-all -caf-all -Executable tag +Executable tagPOS default-language: Haskell2010 Main-Is: Tagger.hs hs-source-dirs: appsrc @@ -102,9 +108,9 @@ ghc-options: -Wall -main-is Tagger -rtsopts -Executable train +Executable trainPOS default-language: Haskell2010 - Main-Is: Trainer.hs + Main-Is: POSTrainer.hs hs-source-dirs: appsrc Build-depends: chatter, @@ -115,8 +121,23 @@ cereal >= 0.4.0.1, containers >= 0.5.0.0 - ghc-options: -Wall -main-is Trainer -rtsopts + ghc-options: -Wall -main-is POSTrainer -rtsopts +Executable trainChunker + default-language: Haskell2010 + Main-Is: ChunkTrainer.hs + hs-source-dirs: appsrc + + Build-depends: chatter, + filepath >= 1.3.0.1, + text >= 0.11.3.0, + base >= 4.6 && <= 6, + bytestring >= 0.10.0.0, + cereal >= 0.4.0.1, + containers >= 0.5.0.0 + + ghc-options: -Wall -main-is ChunkTrainer -rtsopts + Executable eval default-language: Haskell2010 Main-Is: Evaluate.hs @@ -188,4 +209,4 @@ quickcheck-instances, containers - ghc-options: -Wall + ghc-options: -Wall -auto-all -caf-all diff --git a/data/models/README b/data/models/README --- a/data/models/README +++ b/data/models/README @@ -1,7 +1,6 @@ - - -brown-train.model.gz --------------------------------------------------------------------- +brown.pos.model.gz +--------------------------------------------------------------------- Averaged Perceptron tagger and Unambiguous Tagger trained on most of the Brown corpus; the following files were held out for testing: @@ -12,3 +11,18 @@ cp01 cp03 cr02 The remainder of the Brown corpus was used to train this model. + + +--------------------------------------------------------------------- +conll2000.pos.model.gz +--------------------------------------------------------------------- + +Averaged Perceptron tagger and Unambiguous Tagger trained on the Conll +2000 training set. + + +--------------------------------------------------------------------- +conll2000.chunk.model.gz +--------------------------------------------------------------------- + +Averaged Perceptron Chunker trained on the Conll 2000 training set. diff --git a/data/models/brown-train.model.gz b/data/models/brown-train.model.gz deleted file mode 100644 # file too large to diff: data/models/brown-train.model.gz diff --git a/data/models/brown.pos.model.gz b/data/models/brown.pos.model.gz new file mode 100644 # file too large to diff: data/models/brown.pos.model.gz diff --git a/data/models/conll2000.chunk.model.gz b/data/models/conll2000.chunk.model.gz new file mode 100644 Binary files /dev/null and b/data/models/conll2000.chunk.model.gz differ diff --git a/data/models/conll2000.pos.model.gz b/data/models/conll2000.pos.model.gz new file mode 100644 # file too large to diff: data/models/conll2000.pos.model.gz diff --git a/src/NLP/Chunk.hs b/src/NLP/Chunk.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Chunk.hs @@ -0,0 +1,73 @@ +module NLP.Chunk +where + +import Codec.Compression.GZip (decompress) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.List (isSuffixOf) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Serialize (decode, encode) +import System.FilePath (()) + +import NLP.Types +import NLP.Chunk.AvgPerceptronChunker +import qualified NLP.Chunk.AvgPerceptronChunker as Avg + +import qualified NLP.Corpora.Conll as C + +import Paths_chatter + +defaultChunker :: IO (Chunker C.Chunk C.Tag) +defaultChunker = conllChunker + +conllChunker :: IO (Chunker C.Chunk C.Tag) +conllChunker = do + dir <- getDataDir + loadChunker (dir "data" "models" "conll2000.chunk.model.gz") + +train :: (ChunkTag c, Tag t) => Chunker c t -> [ChunkedSentence c t] -> IO (Chunker c t) +train ch exs = chTrainer ch exs + +-- | The default table of tagger IDs to readTagger functions. Each +-- tagger packaged with Chatter should have an entry here. By +-- convention, the IDs use are the fully qualified module name of the +-- tagger package. +chunkerTable :: (ChunkTag c, Tag t) => Map ByteString + (ByteString -> Either String (Chunker c t)) +chunkerTable = Map.fromList + [ (Avg.chunkerID, Avg.readChunker) + ] + +-- | Store a 'Chunker' to disk. +saveChunker :: (ChunkTag c, Tag t) => Chunker c t -> FilePath -> IO () +saveChunker chunker file = BS.writeFile file (serialize chunker) + +-- | Load a 'Chunker' from disk, optionally gunzipping if +-- needed. (based on file extension) +loadChunker :: (ChunkTag c, Tag t) => FilePath -> IO (Chunker c t) +loadChunker file = do + content <- getContent file + case deserialize chunkerTable content of + Left err -> error err + Right chunker -> return chunker + where + getContent :: FilePath -> IO ByteString + getContent f | ".gz" `isSuffixOf` file = fmap (LBS.toStrict . decompress) $ LBS.readFile f + | otherwise = BS.readFile f + + +serialize :: (ChunkTag c, Tag t) => Chunker c t -> ByteString +serialize chunker = encode ( chId chunker, chSerialize chunker) + +deserialize :: (ChunkTag c, Tag t) => + Map ByteString + (ByteString -> Either String (Chunker c t)) + -> ByteString + -> Either String (Chunker c t) +deserialize table bs = do + (theID, payload) <- decode bs + case Map.lookup theID table of + Nothing -> Left ("Could not find ID in Chunker function map: " ++ show theID) + Just fn -> fn payload diff --git a/src/NLP/Chunk/AvgPerceptronChunker.hs b/src/NLP/Chunk/AvgPerceptronChunker.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Chunk/AvgPerceptronChunker.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Avegeraged Perceptron Chunker +-- +module NLP.Chunk.AvgPerceptronChunker + ( mkChunker + , trainInt + , chunk + , chunkSentence + , Chunker(..) + , chunkerID + , readChunker + ) +where + +import NLP.POS.AvgPerceptron ( Perceptron, Feature(..) + , Class(..), predict, update + , averageWeights) +import NLP.Types + +import Data.ByteString (ByteString) +import Data.List (foldl', group) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Either (rights) +import Data.Maybe (fromMaybe) +import Data.Serialize (encode, decode) +import Data.Text (Text) +import qualified Data.Text as T + +import System.Random.Shuffle (shuffleM) + +-- | The type of Chunkers, incorporates chunking, training, +-- serilazitaion and unique IDs for deserialization. +data Chunker c t = Chunker + { chChunker :: [TaggedSentence t] -> [ChunkedSentence c t] + , chTrainer :: [ChunkedSentence c t] -> IO (Chunker c t) + , chSerialize :: ByteString + , chId :: ByteString + } + +-- | The unique ID for this implementation of a 'Chunker' +chunkerID :: ByteString +chunkerID = "NLP.Chunk.AvgPerceptronChunker" + +-- | deserialize an 'AvgPerceptronChunker' from a 'ByteString'. +readChunker :: (ChunkTag c, Tag t) => ByteString -> Either String (Chunker c t) +readChunker bs = do + model <- decode bs + return $ mkChunker model + +itterations :: Int +itterations = 5 + +-- | Create a chunker from a 'Perceptron'. +mkChunker :: (ChunkTag c, Tag t) => Perceptron -> Chunker c t +mkChunker per = Chunker { chChunker = chunk per + , chTrainer = \exs -> do + newPer <- trainInt itterations per exs + return $ mkChunker newPer + , chSerialize = encode per + , chId = chunkerID + } + + +-- | Chunk a list of POS-tagged sentence, generating a parse tree. +chunk :: (ChunkTag c, Tag t) => Perceptron -> [TaggedSentence t] -> [ChunkedSentence c t] +chunk per corpus = map (chunkSentence per) corpus + +-- | Chunk a single POS-tagged sentence. +chunkSentence :: (ChunkTag c, Tag t) => Perceptron -> TaggedSentence t -> ChunkedSentence c t +chunkSentence per (TaggedSent sent) = let + + chunks = [Class "-START-"] ++ map (predictChunk per) features + + features = zipWith3 (getFeatures sent) + [0..] + sent + chunks + + chunkTags = map (\(Class c) -> parseChunk $ T.pack c) $ drop 1 chunks + + in toTree (rights $ chunkTags) sent -- possible hidden failures. + +predictChunk :: Perceptron -> Map Feature Int -> Class +predictChunk model feats = + let predicted = predict model feats + theClass = fromMaybe (Class "O") predicted + in theClass + +-- | Turn an IOB result into a tree. +toTree :: (ChunkTag c, Tag t) => [c] -> [POS t] -> ChunkedSentence c t +toTree chunks tags = + let groups = map (\g -> (head g, length g)) $ group chunks + + groupTags [] _ = [] + groupTags ((g, c):gs) tags = (g, take c tags):(groupTags gs $ drop c tags) + + in ChunkedSent $ concatMap toChunkOr (groupTags groups tags) + +toChunkOr :: (ChunkTag c, Tag t) => (c, [POS t]) -> [ChunkOr c t] +toChunkOr (c, tags) | c == notChunk = map POS_CN tags + | otherwise = [Chunk_CN (Chunk c $ map POS_CN tags)] + + +trainInt :: (ChunkTag c, Tag t) => + Int -- ^ The number of times to iterate over the training + -- data, randomly shuffling after each iteration. (@5@ + -- is a reasonable choice.) + -> Perceptron -- ^ The 'Perceptron' to train. + -> [ChunkedSentence c t] -- ^ The training data. (A list of @[(Text, Tag)]@'s) + -> IO Perceptron -- ^ A trained perceptron. IO is needed + -- for randomization. +trainInt itr per examples = trainCls itr per $ toClassLst $ map unzipChunks examples + +toClassLst :: (ChunkTag c, Tag t) => [(TaggedSentence t, [c])] -> [(TaggedSentence t, [Class])] +toClassLst tagged = map (\(x, y)->(x, map (Class . T.unpack . fromChunk) y)) tagged + +-- | Copied directly from the AvgPerceptronTagger; should be generalized? +trainCls :: Tag t => Int -> Perceptron -> [(TaggedSentence t, [Class])] -> IO Perceptron +trainCls itr per examples = do + trainingSet <- shuffleM $ concat $ take itr $ repeat examples + return $ averageWeights $ foldl' trainSentence per trainingSet + +-- | start markers to ensure all features in context are valid, +-- even for the first "real" tokens. +startToks :: Tag t => [POS t] +startToks = [POS startTag (Token "-START-")] + +-- | end markers to ensure all features are valid, even for +-- the last "real" tokens. +endToks :: Tag t => [POS t] +endToks = [POS endTag (Token "-END-")] + +-- | Train on one sentence. +trainSentence :: Tag t => Perceptron -> (TaggedSentence t, [Class]) -> Perceptron +trainSentence per (TaggedSent sent, ts) = let + + -- This class needs to match the start token. + tags = [Class "-START-"] ++ ts + + features = zipWith3 (getFeatures sent) + [0..] -- index + sent -- words (well, POS values) + tags -- predicted class of previous word. + + fn :: Perceptron -> (Map Feature Int, Class) -> Perceptron + fn model (feats, truth) = let + guess = predictChunk model feats + in update model truth guess $ Map.keys feats + + in foldl' fn per (zip features ts) + + +-- >>> def npchunk_features(sentence, i, history): +-- ... word, pos = sentence[i] +-- ... if i == 0: +-- ... prevword, prevpos = "", "" +-- ... else: +-- ... prevword, prevpos = sentence[i-1] +-- ... if i == len(sentence)-1: +-- ... nextword, nextpos = "", "" +-- ... else: +-- ... nextword, nextpos = sentence[i+1] +-- ... return {"pos": pos, +-- ... "word": word, +-- ... "prevpos": prevpos, +-- ... "nextpos": nextpos, [1] +-- ... "prevpos+pos": "%s+%s" % (prevpos, pos), [2] +-- ... "pos+nextpos": "%s+%s" % (pos, nextpos), +-- ... "tags-since-dt": tags_since_dt(sentence, i)} +getFeatures :: Tag t => + [POS t] -- ^ The full sentence that this word is located in. + -> Int -- ^ The index of the current word. + -> POS t -- ^ The current word/tag pair. + -> Class -- ^ The predicted class of the previous word. + -> Map Feature Int +getFeatures tagged idx word prev = let + context = startToks ++ tagged ++ endToks + + i = idx + 1 -- length startToks + + add :: Map Feature Int -> [Text] -> Map Feature Int + add m args = Map.alter increment (mkFeature $ T.intercalate " " args) m + + increment :: Maybe Int -> Maybe Int + increment Nothing = Just 1 + increment (Just w) = Just (w + 1) + + features :: [[Text]] + features = [ ["pos", showPOStag word] + , ["word", showPOStok word] + , ["prevpos", showPOStag (context!!(i-1))] + , ["prevpos+pos", T.intercalate "+" $ map showPOStag + [ context!!(i-1), word ] + ] + , ["pos+nextpos", T.intercalate "+" $ map showPOStag + [word, context!!(i+1) ] + ] +-- , ["tags-since-dt", ""] + ] + in foldl' add Map.empty features + +mkFeature :: Text -> Feature +mkFeature txt = Feat $ T.copy txt diff --git a/src/NLP/Corpora/Brown.hs b/src/NLP/Corpora/Brown.hs --- a/src/NLP/Corpora/Brown.hs +++ b/src/NLP/Corpora/Brown.hs @@ -11,7 +11,7 @@ import Data.Serialize (Serialize) import qualified Data.Text as T import Data.Text (Text) -import Text.Read (readMaybe) +import Text.Read (readEither) import Test.QuickCheck.Arbitrary (Arbitrary(..)) import Test.QuickCheck.Gen (elements) @@ -24,10 +24,11 @@ | C_VP -- ^ Verb Phrase. | C_PP -- ^ Prepositional Phrase. | C_CL -- ^ Clause. - deriving (Read, Show, Ord, Eq, Generic, Enum) + | C_O -- ^ "Out" not a chunk. + deriving (Read, Show, Ord, Eq, Generic, Enum, Bounded) instance Arbitrary Chunk where - arbitrary = elements [C_NP ..] + arbitrary = elements [minBound ..] instance Serialize Chunk @@ -45,8 +46,11 @@ tagTerm = showBrownTag + startTag = START + endTag = END + instance Arbitrary Tag where - arbitrary = elements [Op_Paren ..] + arbitrary = elements [minBound ..] parseBrownTag :: Text -> Either Error Tag parseBrownTag "(" = Right Op_Paren @@ -58,9 +62,7 @@ parseBrownTag ":" = Right Colon parseBrownTag txt = let normalized = replaceAll tagTxtPatterns (T.toUpper txt) - in case readMaybe $ T.unpack normalized of - Nothing -> Left (T.append "Could not parse: " txt) - Just t -> Right t + in toEitherErr (readEither $ T.unpack normalized) -- | Order matters here: The patterns are replaced in reverse order @@ -90,8 +92,12 @@ instance T.ChunkTag Chunk where fromChunk = T.pack . show + parseChunk txt = toEitherErr $ readEither (T.unpack $ T.append "C_" txt) + notChunk = C_O -data Tag = Op_Paren -- ^ ( +data Tag = START -- ^ START tag, used in training. + | END -- ^ END tag, used in training. + | Op_Paren -- ^ ( | Cl_Paren -- ^ ) | Negator -- ^ *, not n't | Comma -- ^ , @@ -670,4 +676,4 @@ | WRB_pl_IN -- ^ WH-adverb + preposition e.g.; why'n | WRB_pl_MD -- ^ WH-adverb + modal auxillary e.g.; where'd | Unk -- ^ Unknown. - deriving (Read, Show, Ord, Eq, Generic, Enum) + deriving (Read, Show, Ord, Eq, Generic, Enum, Bounded) diff --git a/src/NLP/Corpora/Conll.hs b/src/NLP/Corpora/Conll.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Corpora/Conll.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +-- | Data types representing the POS tags and Chunk tags derived from +-- the Conll2000 training corpus. +module NLP.Corpora.Conll where + +import Data.Serialize (Serialize) +import qualified Data.Text as T +import Data.Text (Text) +import Text.Read (readEither) +import Test.QuickCheck.Arbitrary (Arbitrary(..)) +import Test.QuickCheck.Gen (elements) + +import GHC.Generics + +import qualified NLP.Types.Tags as T +import NLP.Types.General + +data Chunk = ADJP + | ADVP + | CONJP + | INTJ + | LST + | NP -- ^ Noun Phrase. + | PP -- ^ Prepositional Phrase. + | PRT + | SBAR + | UCP + | VP -- ^ Verb Phrase. + | O -- ^ "out"; not a chunk. + deriving (Read, Show, Ord, Eq, Generic, Enum, Bounded) + +instance Arbitrary Chunk where + arbitrary = elements [minBound..] + +instance Serialize Chunk + +instance Serialize Tag + +instance T.Tag Tag where + fromTag = showTag + + parseTag txt = case readTag txt of + Left _ -> Unk + Right t -> t + + -- | Constant tag for "unknown" + tagUNK = Unk + + tagTerm = showTag + + startTag = START + endTag = END + +instance Arbitrary Tag where + arbitrary = elements [minBound ..] + +readTag :: Text -> Either Error Tag +readTag "#" = Right Hash +readTag "$" = Right Dollar +readTag "(" = Right Op_Paren +readTag ")" = Right Cl_Paren +readTag "''" = Right CloseDQuote +readTag "``" = Right OpenDQuote +readTag "," = Right Comma +readTag "." = Right Term +readTag ":" = Right Colon +readTag txt = + let normalized = replaceAll tagTxtPatterns (T.toUpper txt) + in toEitherErr (readEither $ T.unpack normalized) + +-- | Order matters here: The patterns are replaced in reverse order +-- when generating tags, and in top-to-bottom when generating tags. +tagTxtPatterns :: [(Text, Text)] +tagTxtPatterns = [ ("$", "dollar") + ] + +reversePatterns :: [(Text, Text)] +reversePatterns = map (\(x,y) -> (y,x)) tagTxtPatterns + +showTag :: Tag -> Text +showTag Hash = "#" +showTag Op_Paren = "(" +showTag Cl_Paren = ")" +showTag CloseDQuote = "''" +showTag OpenDQuote = "``" +showTag Dollar = "$" +showTag Comma = "," +showTag Term = "." +showTag Colon = ":" +showTag tag = replaceAll reversePatterns (T.pack $ show tag) + +replaceAll :: [(Text, Text)] -> (Text -> Text) +replaceAll patterns = foldl (.) id (map (uncurry T.replace) patterns) + +instance T.ChunkTag Chunk where + fromChunk = T.pack . show + parseChunk txt = toEitherErr $ readEither $ T.unpack txt + notChunk = O + +data Tag = START -- ^ START tag, used in training. + | END -- ^ END tag, used in training. + | Hash -- ^ # + | Dollar -- ^ $ + | CloseDQuote -- ^ '' + | OpenDQuote -- ^ `` + | Op_Paren -- ^ ( + | Cl_Paren -- ^ ) + | Comma -- ^ , + | Term -- ^ . Sentence Terminator + | Colon -- ^ : + | CC + | CD + | DT + | EX + | FW + | IN + | JJ + | JJR + | JJS + | MD + | NN + | NNP + | NNPS + | NNS + | PDT + | POS + | PRP + | PRPdollar + | RB + | RBR + | RBS + | RP + | SYM + | TO + | UH + | VB + | VBD + | VBG + | VBN + | VBP + | VBZ + | WDT + | WP + | WPdollar + | WRB + | Unk + deriving (Read, Show, Ord, Eq, Generic, Enum, Bounded) diff --git a/src/NLP/POS.hs b/src/NLP/POS.hs --- a/src/NLP/POS.hs +++ b/src/NLP/POS.hs @@ -34,6 +34,8 @@ , saveTagger , loadTagger , defaultTagger + , conllTagger + , brownTagger ) where @@ -62,13 +64,25 @@ import qualified NLP.POS.UnambiguousTagger as UT import qualified NLP.Corpora.Brown as B +import qualified NLP.Corpora.Conll as C import Paths_chatter -defaultTagger :: IO (POSTagger B.Tag) -defaultTagger = do +-- | A basic POS tagger. +defaultTagger :: IO (POSTagger C.Tag) +defaultTagger = conllTagger + +-- | A POS tagger that has been trained on the Conll 2000 POS tags. +conllTagger :: IO (POSTagger C.Tag) +conllTagger = do dir <- getDataDir - loadTagger (dir "data" "models" "brown-train.model.gz") + loadTagger (dir "data" "models" "conll2000.pos.model.gz") + +-- | A POS tagger trained on a subset of the Brown corpus. +brownTagger :: IO (POSTagger B.Tag) +brownTagger = do + dir <- getDataDir + loadTagger (dir "data" "models" "brown.pos.model.gz") -- | The default table of tagger IDs to readTagger functions. Each -- tagger packaged with Chatter should have an entry here. By diff --git a/src/NLP/POS/AvgPerceptronTagger.hs b/src/NLP/POS/AvgPerceptronTagger.hs --- a/src/NLP/POS/AvgPerceptronTagger.hs +++ b/src/NLP/POS/AvgPerceptronTagger.hs @@ -212,8 +212,6 @@ -> IO Perceptron -- ^ A trained perceptron. IO is needed -- for randomization. trainInt itr per examples = trainCls itr per $ toClassLst $ map unzipTags examples - -- where - -- toSentPair (xs, ts) = (Sent $ map Token xs, ts) toClassLst :: Tag t => [(Sentence, [t])] -> [(Sentence, [Class])] toClassLst tagged = map (\(x, y)->(x, map (Class . T.unpack . fromTag) y)) tagged diff --git a/src/NLP/Types/General.hs b/src/NLP/Types/General.hs --- a/src/NLP/Types/General.hs +++ b/src/NLP/Types/General.hs @@ -5,12 +5,17 @@ import Data.Serialize (Serialize) import Data.Text (Text) +import qualified Data.Text as T import GHC.Generics import Test.QuickCheck (Arbitrary(..), elements) -- | Just a handy alias for Text type Error = Text + +toEitherErr :: Either String a -> Either Error a +toEitherErr (Left s) = Left (T.pack s) +toEitherErr (Right r) = Right r -- | Boolean type to indicate case sensitivity for textual -- comparisons. diff --git a/src/NLP/Types/IOB.hs b/src/NLP/Types/IOB.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Types/IOB.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} +module NLP.Types.IOB where + +import Prelude hiding (print) +import Control.Applicative ((<$>), (<*>)) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T + +import Test.QuickCheck (Arbitrary(..), elements) +import Test.QuickCheck.Instances () + +import NLP.Types.Tags +import NLP.Types.Tree +import NLP.Types.General (Error) + +-- | Data type to indicate IOB tags for chunking +data IOBChunk chunk tag = BChunk (POS tag) chunk -- ^ Beging marker. + | IChunk (POS tag) chunk -- ^ In chunk tag + | OChunk (POS tag) -- ^ Not in a chunk. + deriving (Read, Show, Eq) + +getPOS :: (ChunkTag c, Tag t) => IOBChunk c t -> POS t +getPOS (BChunk pos _) = pos +getPOS (IChunk pos _) = pos +getPOS (OChunk pos) = pos + +instance (ChunkTag c, Arbitrary c, Arbitrary t, Tag t) => Arbitrary (IOBChunk c t) where + arbitrary = elements =<< do + ic <- IChunk <$> arbitrary <*> arbitrary + bc <- BChunk <$> arbitrary <*> arbitrary + oc <- OChunk <$> arbitrary + return [ic, bc, oc] + +toTaggedSentence :: (ChunkTag c, Tag t) => [IOBChunk c t] -> TaggedSentence t +toTaggedSentence iobChunks = TaggedSent $ map getPOS iobChunks + + +-- | Parse an IOB-chunk encoded line of text. +-- +-- Assumes that the line has three space-delimeted entries, in the format: +-- > token POSTag IOBChunk +-- For example: +-- > > parseIOBLine "We PRP B-NP" :: IOBChunk B.Chunk B.Tag +-- > BChunk (POS B.PRP (Token "We")) B.C_NP +-- +parseIOBLine :: (ChunkTag chunk, Tag tag) => Text -> Either Error (IOBChunk chunk tag) +parseIOBLine txt = + let (tokTxt:tagTxt:iobTxt:_) = T.words txt + token = Token tokTxt + tag = POS (parseTag tagTxt) token + in iobBuilder iobTxt tag + +iobBuilder :: (ChunkTag c, Tag t) => Text -> (POS t -> Either Error (IOBChunk c t)) +iobBuilder iobTxt | "I-" `T.isPrefixOf` iobTxt = \tag -> (IChunk tag) <$> chunk + | "B-" `T.isPrefixOf` iobTxt = \tag -> (BChunk tag) <$> chunk + | otherwise = \tag -> Right (OChunk tag) + where + chunk = parseChunk (T.drop 2 iobTxt) + + +-- | Turn an IOB result into a tree. +toChunkTree :: (ChunkTag c, Tag t) => [IOBChunk c t] -> ChunkedSentence c t +toChunkTree chunks = ChunkedSent $ toChunkOr chunks + + where + toChunkOr :: (ChunkTag c, Tag t) => [IOBChunk c t] -> [ChunkOr c t] + toChunkOr [] = [] + toChunkOr ((OChunk pos):rest) = POS_CN pos : toChunkOr rest + toChunkOr (ch:rest) = case ch of + (BChunk pos chunk) -> (Chunk_CN (Chunk chunk children)) : toChunkOr theTail + (IChunk pos chunk) -> (Chunk_CN (Chunk chunk children)) : toChunkOr theTail + where + (ichunks, theTail) = span isIChunk rest + + toPOScn (IChunk pos _) = Just $ POS_CN pos + toPOScn _ = Nothing + + -- children :: [ChunkOr c t] + children = mapMaybe toPOScn ichunks + + isIChunk (IChunk _ _) = True + isIChunk _ = False + +-- | Parse an IOB-encoded corpus. +parseIOB :: (ChunkTag chunk, Tag tag) => Text -> Either Error [[IOBChunk chunk tag]] +parseIOB corpora = + let sentences = getSentences corpora + in sequence $ map parseSentence sentences + +parseSentence :: (ChunkTag chunk, Tag tag) => [Text] -> Either Error [IOBChunk chunk tag] +parseSentence input = sequence (map parseIOBLine input) + +-- | Just split a body of text into lines, and then into "paragraphs". +-- Each resulting sub list is separated by empty lines in the original text. +-- +-- e.g.; +-- > > getSentences "He\njumped\n.\n\nShe\njumped\n." +-- > [["He", "jumped", "."], ["She","jumped", "."]] +-- +getSentences :: Text -> [[Text]] +getSentences corpora = + let theLines = map T.strip $ T.lines corpora + + sentences :: [Text] -> [[Text]] + sentences [] = [] + sentences ("":xs) = sentences xs + sentences input = let (sent, rest) = break (== T.empty) input + in (sent:sentences rest) + + in sentences theLines diff --git a/src/NLP/Types/Tags.hs b/src/NLP/Types/Tags.hs --- a/src/NLP/Types/Tags.hs +++ b/src/NLP/Types/Tags.hs @@ -13,12 +13,16 @@ import Test.QuickCheck (Arbitrary(..), NonEmptyList(..)) import Test.QuickCheck.Instances () +import NLP.Types.General (Error) + -- | The class of things that can be regarded as 'chunks'; Chunk tags -- are much like POS tags, but should not be confused. Generally, -- chunks distinguish between different phrasal categories (e.g.; Noun -- Phrases, Verb Phrases, Prepositional Phrases, etc..) class (Ord a, Eq a, Read a, Show a, Generic a, Serialize a) => ChunkTag a where fromChunk :: a -> Text + parseChunk :: Text -> Either Error a + notChunk :: a -- | The class of POS Tags. -- @@ -40,7 +44,8 @@ parseTag :: Text -> a tagUNK :: a tagTerm :: a -> Text - + startTag :: a + endTag :: a -- | A fall-back 'ChunkTag' instance, analogous to 'RawTag' newtype RawChunk = RawChunk Text @@ -50,6 +55,8 @@ instance ChunkTag RawChunk where fromChunk (RawChunk ch) = ch + parseChunk txt = Right (RawChunk txt) + notChunk = RawChunk "O" -- | A fallback POS tag instance. newtype RawTag = RawTag Text @@ -67,6 +74,9 @@ tagUNK = RawTag "Unk" tagTerm (RawTag t) = t + + startTag = RawTag "-START-" + endTag = RawTag "-END-" instance Arbitrary RawTag where arbitrary = do diff --git a/src/NLP/Types/Tree.hs b/src/NLP/Types/Tree.hs --- a/src/NLP/Types/Tree.hs +++ b/src/NLP/Types/Tree.hs @@ -35,6 +35,17 @@ data ChunkedSentence chunk tag = ChunkedSent [ChunkOr chunk tag] deriving (Read, Show, Eq) +-- | A data type to represent the portions of a parse tree for Chunks. +-- Note that this part of the parse tree could be a POS tag with no +-- chunk. +data ChunkOr chunk tag = Chunk_CN (Chunk chunk tag) + | POS_CN (POS tag) + deriving (Read, Show, Eq) + +-- | A Chunk that strictly contains chunks or POS tags. +data Chunk chunk tag = Chunk chunk [ChunkOr chunk tag] + deriving (Read, Show, Eq) + instance (ChunkTag c, Arbitrary c, Arbitrary t, Tag t) => Arbitrary (ChunkedSentence c t) where arbitrary = ChunkedSent <$> arbitrary @@ -67,6 +78,20 @@ topair (POS tag tok) = (tag, tok) in (Sent toks, tags) +unzipChunks :: (ChunkTag c, Tag t) => ChunkedSentence c t -> (TaggedSentence t, [c]) +unzipChunks (ChunkedSent cs) = (TaggedSent poss, chunks) + where + (poss, chunks) = unzip (concatMap f cs) + +-- f :: ChunkOr chunk tag -> [(POS tag, chunk)] + f (POS_CN postag) = [(postag, notChunk)] + f (Chunk_CN (Chunk chTag subTree)) = map (updateChunk chTag) (concatMap f subTree) + +-- updateChunk :: c -> (POS t, c) -> (POS t, c) + updateChunk chunk (ptag, oldChunk) | oldChunk == notChunk = (ptag, chunk) + | otherwise = (ptag, oldChunk) + + -- | Combine the results of POS taggers, using the second param to -- fill in 'tagUNK' entries, where possible. combine :: Tag t => [TaggedSentence t] -> [TaggedSentence t] -> [TaggedSentence t] @@ -85,12 +110,6 @@ | t1 /= tagUNK = POS t1 txt1 | otherwise = POS t2 txt1 --- | A data type to represent the portions of a parse tree for Chunks. --- Note that this part of the parse tree could be a POS tag with no --- chunk. -data ChunkOr chunk tag = Chunk_CN (Chunk chunk tag) - | POS_CN (POS tag) - deriving (Read, Show, Eq) instance (ChunkTag c, Arbitrary c, Arbitrary t, Tag t) => Arbitrary (ChunkOr c t) where arbitrary = elements =<< do @@ -106,23 +125,24 @@ mkChink :: (ChunkTag chunk, Tag tag) => tag -> Token -> ChunkOr chunk tag mkChink tag token = POS_CN (POS tag token) --- | A Chunk that strictly contains chunks or POS tags. -data Chunk chunk tag = Chunk chunk [ChunkOr chunk tag] - deriving (Read, Show, Eq) instance (ChunkTag c, Arbitrary c, Arbitrary t, Tag t) => Arbitrary (Chunk c t) where arbitrary = Chunk <$> arbitrary <*> arbitrary -- | A POS-tagged token. -data POS tag = POS tag Token - deriving (Read, Show, Eq) +data POS tag = POS { posTag :: tag + , posToken :: Token + } deriving (Read, Show, Eq) instance (Arbitrary t, Tag t) => Arbitrary (POS t) where arbitrary = POS <$> arbitrary <*> arbitrary -- | Show the underlying text token only. -showPOS :: Tag tag => POS tag -> Text -showPOS (POS _ (Token txt)) = txt +showPOStok :: Tag tag => POS tag -> Text +showPOStok (POS _ (Token txt)) = txt + +showPOStag :: Tag tag => POS tag -> Text +showPOStag = tagTerm . posTag -- | Show the text and tag. printPOS :: Tag tag => POS tag -> Text diff --git a/tests/src/IntegrationTests.hs b/tests/src/IntegrationTests.hs --- a/tests/src/IntegrationTests.hs +++ b/tests/src/IntegrationTests.hs @@ -21,15 +21,21 @@ import qualified NLP.POS.UnambiguousTagger as UT import qualified NLP.Corpora.Brown as B +import qualified NLP.Corpora.Conll as C import TestUtils tests :: Test tests = buildTest $ do - tagger <- defaultTagger :: IO (POSTagger B.Tag) + brown <- brownTagger :: IO (POSTagger B.Tag) + def <- defaultTagger :: IO (POSTagger C.Tag) return $ testGroup "Integration Tests" [ testGroup "Default Tagger" $ - map (genTest $ tagText tagger) + map (genTest $ tagText def) + [ ("Simple 1", "The dog jumped.", "The/DT dog/NN jumped/VBD ./.") + ] + , testGroup "Brown Tagger" $ + map (genTest $ tagText brown) [ ("Simple 1", "The dog jumped.", "The/AT dog/NN jumped/VBD ./.") ] , testGroup "POS Serialization" $ diff --git a/tests/src/Main.hs b/tests/src/Main.hs --- a/tests/src/Main.hs +++ b/tests/src/Main.hs @@ -22,6 +22,7 @@ import qualified Data.DefaultMapTests as DefMap import qualified IntegrationTests as IT import qualified NLP.Corpora.BrownTests as Brown +import qualified NLP.Corpora.ConllTests as Conll import qualified NLP.Extraction.ParsecTests as Parsec import qualified NLP.POS.AvgPerceptronTagger as APT import qualified NLP.POS.UnambiguousTaggerTests as UT @@ -29,6 +30,8 @@ import qualified NLP.POSTests as POS import qualified NLP.Similarity.VectorSimTests as Vec import qualified NLP.TypesTests as TypeTests +import qualified NLP.Types.IOBTests as IOB +import qualified NLP.Chunk.AvgPerceptronChunkerTests as APC import Corpora @@ -51,12 +54,6 @@ , testGroup "miniCorpora2 - POSTagger train" $ map (trainAndTagTestVTrainer miniCorpora1) [ ("the dog jumped .", "the/DT dog/NN jumped/VB ./.") ] - -- , skip $ testGroup "brown CA01" $ - -- map (trainAndTagTestFileCorpus brownCA01) - -- [ ("the dog jumped .", "the/at dog/nn jumped/Unk ./.") ] - -- , skip $ testGroup "brown CA" $ - -- map (trainAndTagTestIO brownCA) - -- [ ("the dog jumped .", "the/at dog/nn jumped/vbd ./.") ] ] , APT.tests , Backoff.tests @@ -69,6 +66,9 @@ , Parsec.tests , IT.tests , Brown.tests + , Conll.tests + , IOB.tests + , APC.tests ]