chatter 0.4.0.0 → 0.5.0.0

raw patch · 18 files changed

+453/−317 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• appsrc/ChunkTrainer.hs +1/−1
• changelog.md +31/−0
• chatter.cabal +9/−2
• data/models/README +14/−0
• data/models/conll2000.chunk.model.gz binary
• data/models/conll2000.pos.model.gz too large to diff
• src/NLP/Chunk.hs +34/−1
• src/NLP/Chunk/AvgPerceptronChunker.hs +16/−4
• src/NLP/Corpora/Brown.hs +2/−0
• src/NLP/Corpora/Conll.hs +48/−35
• src/NLP/Extraction/Parsec.hs +9/−1
• src/NLP/ML/AvgPerceptron.hs +269/−0
• src/NLP/POS/AvgPerceptron.hs +0/−269
• src/NLP/POS/AvgPerceptronTagger.hs +3/−3
• src/NLP/Types/Tags.hs +4/−0
• src/NLP/Types/Tree.hs +10/−0
• tests/src/AvgPerceptronTests.hs +1/−1
• tests/src/Main.hs +2/−0

@@ -5,7 +5,7 @@ import qualified Data.Text.IO as T import System.Environment (getArgs) -import NLP.POS.AvgPerceptron (emptyPerceptron)+import NLP.ML.AvgPerceptron (emptyPerceptron) import qualified NLP.Chunk.AvgPerceptronChunker as Avg import NLP.Chunk (train, saveChunker) import NLP.Types.IOB

@@ -1,3 +1,34 @@+= 0.5.0.0 =++ - Added chunk, chunkText, and chunkStr functions to NLP.Chunk to+   make it easier to experiment with the chunker.++ - Added a formatting function to show ChunkedSententences+   (NLP.Types.Tree.showChunkedSent) that formats chunks in bracket notation, eg:++   > chunkText tgr chk "The dog jumped over the reluctant cat."+   "[NP The/DT dog/NN] [VP jumped/VBD] [NP over/IN the/DT reluctant/JJ cat/NN] ./."++   Notice that the features still need some tuning for the chunker.++ - Moved the AveragePerceptron module into a NLP.ML (Machine Learning) module.++ - Added the 'tags-since-dt' feature to the AveragePerceptronChunker features+   and retrained the Conll2000 models.++= 0.4.0.0 =++ - Added phrasal chunking via an Averaged Perceptron Chunker,+   trained on the Conll 2000 corpus.++ - Added a POS tagger trained on the Conll 2000 corpus, because the+   Conll chunker relies on that tagset.++ - Set the Conll 2000 POS tagger to the defaultTagger. Note that+   the tagset is much smaller than the Brown tagset used by the+   previous defaultTagger.  The Brown tagger is still available from+   NLP.POS.brownTagger.+ = 0.3.0.1 =   - Bumped dependency on base to >= 4.6 (from >= 4) because of

@@ -1,5 +1,5 @@ name:                chatter-version:             0.4.0.0+version:             0.5.0.0 synopsis:            A library of simple NLP algorithms. description:         chatter is a collection of simple Natural Language                      Processing algorithms.@@ -11,10 +11,17 @@                        by Matthew Honnibal:                        (<http://honnibal.wordpress.com/2013/09/11/a-good-part-of-speechpos-tagger-in-about-200-lines-of-python/>) See 'NLP.POS' for the details of part-of-speech tagging with chatter.                      .+                     * Phrasal Chunking (also with an Averaged Perceptron) to identify arbitrary chunks based on training data.+                     .                      * Document similarity; A cosine-based similarity measure, and TF-IDF calculations,                        are available in the 'NLP.Similarity.VectorSim' module.                      .                      * Information Extraction patterns via (<http://www.haskell.org/haskellwiki/Parsec/>) Parsec+                     .+                     Chatter comes with models for POS tagging and+                     Phrasal Chunking that have been trained on the+                     Brown corpus (POS only) and the Conll2000 corpus+                     (POS and Chunking) homepage:            http://github.com/creswick/chatter Bug-Reports:         http://github.com/creswick/chatter/issues category:            Natural language processing@@ -42,12 +49,12 @@    Other-modules:    Paths_chatter     Exposed-modules:  NLP.POS-                     NLP.POS.AvgPerceptron                      NLP.POS.AvgPerceptronTagger                      NLP.POS.LiteralTagger                      NLP.POS.UnambiguousTagger                      NLP.Chunk                      NLP.Chunk.AvgPerceptronChunker+                     NLP.ML.AvgPerceptron                      NLP.Types                      NLP.Types.General                      NLP.Types.IOB

@@ -21,8 +21,22 @@ 2000 training set.  +Generated by:++$ time ./dist/build/trainPOS/trainPOS ~/nltk_data/corpora/conll2000/train.txt conll2000.pos.model++real	2m48.866s+user	2m44.500s+sys	0m1.898s+ --------------------------------------------------------------------- conll2000.chunk.model.gz ---------------------------------------------------------------------  Averaged Perceptron Chunker trained on the Conll 2000 training set.++ $ time ./dist/build/trainChunker/trainChunker ~/nltk_data/corpora/conll2000/train.txt conll2000.chunk.model++real	0m20.730s+user	0m20.298s+sys	0m0.290s

binary file changed (204463 → 630879 bytes)

file too large to diff

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module NLP.Chunk where @@ -9,26 +10,58 @@ import           Data.Map                    (Map) import qualified Data.Map                    as Map import           Data.Serialize              (decode, encode)+import           Data.Text                   (Text)+import qualified Data.Text                   as T import           System.FilePath             ((</>)) +import           NLP.POS                     (tag) import           NLP.Types-import           NLP.Chunk.AvgPerceptronChunker+import           NLP.Chunk.AvgPerceptronChunker (Chunker(..)) import qualified NLP.Chunk.AvgPerceptronChunker as Avg  import qualified NLP.Corpora.Conll as C  import           Paths_chatter +-- | A basic Phrasal chunker. defaultChunker :: IO (Chunker C.Chunk C.Tag) defaultChunker = conllChunker +-- | Convenient function to load the Conll2000 Chunker. conllChunker :: IO (Chunker C.Chunk C.Tag) conllChunker = do   dir <- getDataDir   loadChunker (dir </> "data" </> "models" </> "conll2000.chunk.model.gz") +-- | Train a chunker on a set of additional examples. train :: (ChunkTag c, Tag t) => Chunker c t -> [ChunkedSentence c t] -> IO (Chunker c t) train ch exs = chTrainer ch exs++-- | Chunk a 'TaggedSentence' that has been produced by a Chatter+-- tagger, producing a rich representation of the Chunks and the Tags+-- detected.+--+-- If you just want to see chunked output from standard text, you+-- probably want 'chunkText' or 'chunkStr'.+chunk :: (ChunkTag c, Tag t) => Chunker c t -> [TaggedSentence t] -> [ChunkedSentence c t]+chunk chk input = chChunker chk input+++-- | Convenience funciton to Tokenize, POS-tag, then Chunk the+-- provided text, and format the result in an easy-to-read format.+--+-- > > tgr <- defaultTagger+-- > > chk <- defaultChunker+-- > > chunkText tgr chk "The brown dog jumped over the lazy cat."+-- > "[NP The/DT brown/NN dog/NN] [VP jumped/VBD] [NP over/IN the/DT lazy/JJ cat/NN] ./."+--+chunkText :: (ChunkTag c, Tag t) => POSTagger t -> Chunker c t -> Text -> Text+chunkText tgr chk input = T.intercalate " " $ map showChunkedSent $ chunk chk $ tag tgr input+++-- | A wrapper around 'chunkText' that packs strings.+chunkStr :: (ChunkTag c, Tag t) => POSTagger t -> Chunker c t -> String -> String+chunkStr tgr chk str = T.unpack $ chunkText tgr chk $ T.pack str  -- | The default table of tagger IDs to readTagger functions.  Each -- tagger packaged with Chatter should have an entry here.  By

@@ -12,9 +12,9 @@   ) where -import NLP.POS.AvgPerceptron ( Perceptron, Feature(..)-                             , Class(..), predict, update-                             , averageWeights)+import NLP.ML.AvgPerceptron ( Perceptron, Feature(..)+                            , Class(..), predict, update+                            , averageWeights) import NLP.Types  import Data.ByteString (ByteString)@@ -196,9 +196,21 @@              , ["pos+nextpos", T.intercalate "+" $ map showPOStag                                  [word, context!!(i+1) ]                ]---             , ["tags-since-dt", ""]+             , ["tags-since-dt", tagsSinceDt $ take idx tagged]              ]+   in foldl' add Map.empty features++tagsSinceDt :: Tag t => [POS t] -> Text+tagsSinceDt posToks =+  T.intercalate "-" $ tagsSinceHelper $ reverse posToks++tagsSinceHelper :: Tag t => [POS t] -> [Text]+tagsSinceHelper []      = []+tagsSinceHelper (pt@(POS t _):ts)+    | isDt t    = []+    | otherwise = [ (showPOStag pt) ] ++ (tagsSinceHelper ts)+  mkFeature :: Text -> Feature mkFeature txt = Feat $ T.copy txt

@@ -49,6 +49,8 @@   startTag = START   endTag = END +  isDt tag = tag `elem` [DT, DTdollar, DT_pl_BEZ, DT_pl_MD, DTI, DTS, DTS_pl_BEZ, DTX]+ instance Arbitrary Tag where   arbitrary = elements [minBound ..] 

@@ -52,6 +52,8 @@   startTag = START   endTag = END +  isDt tag = tag `elem` [DT]+ instance Arbitrary Tag where   arbitrary = elements [minBound ..] @@ -98,6 +100,15 @@   parseChunk txt = toEitherErr $ readEither $ T.unpack txt   notChunk = O +-- | These tags may actually be the Penn Treebank tags.  But I have+-- not (yet?) seen the punctuation tags added to the Penn set.+--+-- This particular list was complied from the union of:+--+--   * All tags used on the Conll2000 training corpus. (contributing the punctuation tags)+--   * The PennTreebank tags, listed here: <https://www.ling.upenn.edu/courses/Fall_2003/ling001/penn_treebank_pos.html> (which contributed LS over the items in the corpus).+--   * The tags: START, END, and Unk, which are used by Chatter.+-- data Tag = START -- ^ START tag, used in training.          | END -- ^ END tag, used in training.          | Hash -- ^ #@@ -109,40 +120,42 @@          | 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+         | CC -- ^ Coordinating conjunction+         | CD -- ^ Cardinal number+         | DT -- ^ Determiner+         | EX -- ^ Existential there+         | FW -- ^ Foreign word+         | IN -- ^ Preposition or subordinating conjunction+         | JJ -- ^ Adjective+         | JJR -- ^ Adjective, comparative+         | JJS -- ^ Adjective, superlative+         | LS -- ^ List item marker+         | MD -- ^ Modal+         | NN -- ^ Noun, singular or mass+         | NNS -- ^ Noun, plural+         | NNP -- ^ Proper noun, singular+         | NNPS -- ^ Proper noun, plural+         | PDT -- ^ Predeterminer+         | POS -- ^ Possessive ending+         | PRP -- ^ Personal pronoun+         | PRPdollar -- ^ Possessive pronoun+         | RB -- ^ Adverb+         | RBR -- ^ Adverb, comparative+         | RBS -- ^ Adverb, superlative+         | RP -- ^ Particle+         | SYM -- ^ Symbol+         | TO -- ^ to+         | UH -- ^ Interjection+         | VB -- ^ Verb, base form+         | VBD -- ^ Verb, past tense+         | VBG -- ^ Verb, gerund or present participle+         | VBN -- ^ Verb, past participle+         | VBP -- ^ Verb, non-3rd person singular present+         | VBZ -- ^ Verb, 3rd person singular present+         | WDT -- ^ Wh-determiner+         | WP -- ^ Wh-pronoun+         | WPdollar -- ^ Possessive wh-pronoun+         | WRB -- ^ Wh-adverb          | Unk   deriving (Read, Show, Ord, Eq, Generic, Enum, Bounded)+

@@ -35,7 +35,7 @@ import Text.Parsec.Pos  (newPos)  import NLP.Types (TaggedSentence(..), Tag(..), CaseSensitive(..),-                                POS(..), Token(..))+                  POS(..), Token(..), ChunkedSentence(..), ChunkOr(..), ChunkTag)  instance (Monad m, Tag t) => Stream (TaggedSentence t) m (POS t) where   uncons (TaggedSent ts) = do@@ -43,6 +43,14 @@     case mRes of       Nothing           -> return $ Nothing       Just (mTok, rest) -> return $ Just (mTok, TaggedSent rest)+  {-# INLINE uncons #-}++instance (Monad m, ChunkTag c, Tag t) => Stream (ChunkedSentence c t) m (ChunkOr c t) where+  uncons (ChunkedSent ts) = do+    mRes <- uncons ts+    case mRes of+      Nothing           -> return $ Nothing+      Just (mTok, rest) -> return $ Just (mTok, ChunkedSent rest)   {-# INLINE uncons #-}  -- | A Parsec parser.

@@ -0,0 +1,269 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Average Perceptron implementation of Part of speech tagging,+-- adapted for Haskell from this python implementation, which is described on the blog post:+--+--  * <http://honnibal.wordpress.com/2013/09/11/a-good-part-of-speechpos-tagger-in-about-200-lines-of-python/>+--+-- The Perceptron code can be found on github:+--+--  * <https://github.com/sloria/TextBlob/blob/dev/text/_perceptron.py>+--+module NLP.ML.AvgPerceptron+  ( Perceptron(..)+  , Class(..)+  , Weight+  , Feature(..)+  , emptyPerceptron+  , predict+  , train+  , update+  , averageWeights+  )+where++import Control.DeepSeq (NFData)+import Data.List (foldl')+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe)+import Data.Serialize (Serialize)+import Data.Text (Text)+import System.Random.Shuffle (shuffleM)+import GHC.Generics++import NLP.Types ()++newtype Feature = Feat Text+    deriving (Read, Show, Eq, Ord, Generic)++instance Serialize Feature++-- | The classes that the perceptron assigns are represnted with a+-- newtype-wrapped String.+--+-- Eventually, I think this should become a typeclass, so the classes+-- can be defined by the users of the Perceptron (such as custom POS+-- tag ADTs, or more complex classes).+newtype Class = Class String+    deriving (Read, Show, Eq, Ord, Generic)++instance Serialize Class++-- | Typedef for doubles to make the code easier to read, and to make+-- this simple to change if necessary.+type Weight = Double++infinity :: Weight+infinity = recip 0++-- | An empty perceptron, used to start training.+emptyPerceptron :: Perceptron+emptyPerceptron = Perceptron { weights = Map.empty+                             , totals = Map.empty+                             , tstamps = Map.empty+                             , instances = 0 }++-- | The perceptron model.+data Perceptron = Perceptron {+    -- | Each feature gets its own weight vector, so weights is a+    -- dict-of-dicts+    weights :: Map Feature (Map Class Weight)++    -- | The accumulated values, for the averaging. These will be+    -- keyed by feature/clas tuples+    , totals :: Map (Feature, Class) Weight++    -- | The last time the feature was changed, for the averaging. Also+    -- keyed by feature/clas tuples+    -- (tstamps is short for timestamps)+    , tstamps :: Map (Feature, Class) Int++    -- | Number of instances seen+    , instances :: Int+    } deriving (Read, Show, Eq, Generic)++instance Serialize Perceptron+instance NFData Perceptron++incrementInstances :: Perceptron -> Perceptron+incrementInstances p = p { instances = 1 + (instances p) }++getTimestamp :: Perceptron -> (Feature, Class) -> Int+getTimestamp p param = Map.findWithDefault 0 param (tstamps p)++getTotal :: Perceptron -> (Feature, Class) -> Weight+getTotal p param = Map.findWithDefault 0 param (totals p)++getFeatureWeight :: Perceptron -> Feature -> Map Class Weight+getFeatureWeight p f = Map.findWithDefault Map.empty f (weights p)++-- | Predict a class given a feature vector.+--+-- Ported from python:+--+-- > def predict(self, features):+-- >     '''Dot-product the features and current weights and return the best label.'''+-- >     scores = defaultdict(float)+-- >     for feat, value in features.items():+-- >         if feat not in self.weights or value == 0:+-- >             continue+-- >         weights = self.weights[feat]+-- >         for label, weight in weights.items():+-- >             scores[label] += value * weight+-- >     # Do a secondary alphabetic sort, for stability+-- >     return max(self.classes, key=lambda label: (scores[label], label))+--+predict :: Perceptron -> Map Feature Int -> Maybe Class+predict per features = -- find highest ranked score in finalScores:+    -- trace ("features: "++ show features ++ "\n") $+    -- trace ("finalScores: "++ show sortedScores ++ "\n") $+    sortedScores+    where+      sortedScores :: Maybe Class+      sortedScores = fst $ Map.foldlWithKey ranker (Nothing, negate infinity) finalScores++      ranker r@(_, ow) nc nw | nw > ow   = (Just nc, nw)+                             | otherwise = r++      finalScores :: Map Class Weight+      finalScores = Map.foldlWithKey fn Map.empty features++      fn :: Map Class Weight -> Feature -> Int -> Map Class Weight+      fn scores f  v+         | v > 0 = case Map.lookup f (weights per) of+                     Just vec -> Map.foldlWithKey (doProd v) scores vec+                     Nothing  -> scores+         | otherwise = scores++      doProd :: Int -> Map Class Weight -> Class -> Weight -> Map Class Weight+      doProd value scores label weight =+        Map.alter (updater (weight * (fromIntegral value))) label scores++      updater :: Weight -> Maybe Weight -> Maybe Weight+      updater newVal Nothing  = Just newVal+      updater newVal (Just v) = Just (v + newVal)++-- | Update the perceptron with a new example.+--+-- > update(self, truth, guess, features)+-- >    ...+-- >         self.i += 1+-- >         if truth == guess:+-- >             return None+-- >         for f in features:+-- >             weights = self.weights.setdefault(f, {}) -- setdefault is Map.findWithDefault, and destructive.+-- >             upd_feat(truth, f, weights.get(truth, 0.0), 1.0)+-- >             upd_feat(guess, f, weights.get(guess, 0.0), -1.0)+-- >         return None+--+update :: Perceptron -> Class -> Class -> [Feature] -> Perceptron+update per truth guess features+  | truth == guess = incrementInstances per+  | otherwise      = foldr loopBody per features+    where+      loopBody :: Feature -> Perceptron -> Perceptron+      loopBody f p = let+        fweights  = getFeatureWeight p f+        cweight c = Map.findWithDefault 0 c fweights+        in upd_feat guess f (cweight guess) (-1)+             (upd_feat truth f (cweight truth) 1 p)++-- | ported from python:+--+-- > def update(self, truth, guess, features):+-- >        '''Update the feature weights.'''+-- >        def upd_feat(c, f, w, v):+-- >           param = (f, c)+-- >           self._totals[param] += (self.i - self._tstamps[param]) * w+-- >           self._tstamps[param] = self.i+-- >           self.weights[f][c] = w + v+upd_feat :: Class -> Feature -> Weight -> Weight -> Perceptron -> Perceptron+upd_feat c f w v p = let+    newInstances = 1 + (instances p) -- increment the instance counter.++    -- self._totals[param] += (self.i - self._tstamps[param]) * w+    paramTstamp = newInstances - getTimestamp p (f, c)+    tmpTotal  = (getTotal p (f, c)) + ((fromIntegral paramTstamp) * w)+    newTotals = Map.insert (f, c) tmpTotal (totals p)++    -- self._tstamps[param] = self.i+    newTstamps = Map.insert (f, c) newInstances (tstamps p)++    -- self.weights[f][c] = w + v+    newWeights = Map.insert f (Map.insert c (w + v) (getFeatureWeight p f)) (weights p)++    in p { totals = newTotals+         , tstamps = newTstamps+         , weights = newWeights }+++-- | Average the weights+--+-- Ported from Python:+--+-- > def average_weights(self):+-- >     for feat, weights in self.weights.items():+-- >         new_feat_weights = {}+-- >         for clas, weight in weights.items():+-- >             param = (feat, clas)+-- >             total = self._totals[param]+-- >             total += (self.i - self._tstamps[param]) * weight+-- >             averaged = round(total / float(self.i), 3)+-- >             if averaged:+-- >                 new_feat_weights[clas] = averaged+-- >         self.weights[feat] = new_feat_weights+-- >     return None+--+averageWeights :: Perceptron -> Perceptron+averageWeights per | (instances per) == 0 = per+                   | otherwise = per { weights = Map.mapWithKey avgWeights $ weights per+                                     , tstamps = Map.mapWithKey (\_ _->0) (tstamps per)+                                     , instances = 0 }+  where+    avgWeights :: Feature -> Map Class Weight -> Map Class Weight+    avgWeights feat ws = Map.foldlWithKey (doAvg feat) Map.empty ws++    doAvg :: Feature -> Map Class Weight -> Class -> Weight -> Map Class Weight+    doAvg f acc c w = let+      param = (f, c)+      paramTotal = instances per - getTimestamp per param++      total :: Weight+      total = (getTotal per param) + ((fromIntegral paramTotal) * w)+      averaged = roundTo 3 (total / (fromIntegral $ instances per))+      in if 0 == averaged+           then acc+           else Map.insert c averaged acc++-- | round a fractional number to a specified decimal place.+--+-- >>> roundTo 2 3.1459+-- 3.15+--+roundTo :: RealFrac a => Int -> a -> a+roundTo n f = (fromInteger $ round $ f * (10^n)) / (10.0^^n)+++-- Train a perceptron+--+-- Ported from Python:+-- > def train(nr_iter, examples):+-- >     model = Perceptron()+-- >     for i in range(nr_iter):+-- >         random.shuffle(examples)+-- >         for features, class_ in examples:+-- >             scores = model.predict(features)+-- >             guess, score = max(scores.items(), key=lambda i: i[1])+-- >             if guess != class_:+-- >                 model.update(class_, guess, features)+-- >     model.average_weights()+-- >     return model+train :: Int -> Perceptron -> [(Map Feature Int, Class)] -> IO Perceptron+train itr model exs = do+  trainingSet <- shuffleM $ concat $ take itr $ repeat exs+  return $ averageWeights $ foldl' trainEx model trainingSet++trainEx :: Perceptron -> (Map Feature Int, Class) -> Perceptron+trainEx model (feats, truth) = let+  guess = fromMaybe (Class "Unk") $ predict model feats+  in update model truth guess $ Map.keys feats

@@ -1,269 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Average Perceptron implementation of Part of speech tagging,--- adapted for Haskell from this python implementation, which is described on the blog post:------  * <http://honnibal.wordpress.com/2013/09/11/a-good-part-of-speechpos-tagger-in-about-200-lines-of-python/>------ The Perceptron code can be found on github:------  * <https://github.com/sloria/TextBlob/blob/dev/text/_perceptron.py>----module NLP.POS.AvgPerceptron-  ( Perceptron(..)-  , Class(..)-  , Weight-  , Feature(..)-  , emptyPerceptron-  , predict-  , train-  , update-  , averageWeights-  )-where--import Control.DeepSeq (NFData)-import Data.List (foldl')-import qualified Data.Map.Strict as Map-import Data.Map.Strict (Map)-import Data.Maybe (fromMaybe)-import Data.Serialize (Serialize)-import Data.Text (Text)-import System.Random.Shuffle (shuffleM)-import GHC.Generics--import NLP.Types ()--newtype Feature = Feat Text-    deriving (Read, Show, Eq, Ord, Generic)--instance Serialize Feature---- | The classes that the perceptron assigns are represnted with a--- newtype-wrapped String.------ Eventually, I think this should become a typeclass, so the classes--- can be defined by the users of the Perceptron (such as custom POS--- tag ADTs, or more complex classes).-newtype Class = Class String-    deriving (Read, Show, Eq, Ord, Generic)--instance Serialize Class---- | Typedef for doubles to make the code easier to read, and to make--- this simple to change if necessary.-type Weight = Double--infinity :: Weight-infinity = recip 0---- | An empty perceptron, used to start training.-emptyPerceptron :: Perceptron-emptyPerceptron = Perceptron { weights = Map.empty-                             , totals = Map.empty-                             , tstamps = Map.empty-                             , instances = 0 }---- | The perceptron model.-data Perceptron = Perceptron {-    -- | Each feature gets its own weight vector, so weights is a-    -- dict-of-dicts-    weights :: Map Feature (Map Class Weight)--    -- | The accumulated values, for the averaging. These will be-    -- keyed by feature/clas tuples-    , totals :: Map (Feature, Class) Weight--    -- | The last time the feature was changed, for the averaging. Also-    -- keyed by feature/clas tuples-    -- (tstamps is short for timestamps)-    , tstamps :: Map (Feature, Class) Int--    -- | Number of instances seen-    , instances :: Int-    } deriving (Read, Show, Eq, Generic)--instance Serialize Perceptron-instance NFData Perceptron--incrementInstances :: Perceptron -> Perceptron-incrementInstances p = p { instances = 1 + (instances p) }--getTimestamp :: Perceptron -> (Feature, Class) -> Int-getTimestamp p param = Map.findWithDefault 0 param (tstamps p)--getTotal :: Perceptron -> (Feature, Class) -> Weight-getTotal p param = Map.findWithDefault 0 param (totals p)--getFeatureWeight :: Perceptron -> Feature -> Map Class Weight-getFeatureWeight p f = Map.findWithDefault Map.empty f (weights p)---- | Predict a class given a feature vector.------ Ported from python:------ > def predict(self, features):--- >     '''Dot-product the features and current weights and return the best label.'''--- >     scores = defaultdict(float)--- >     for feat, value in features.items():--- >         if feat not in self.weights or value == 0:--- >             continue--- >         weights = self.weights[feat]--- >         for label, weight in weights.items():--- >             scores[label] += value * weight--- >     # Do a secondary alphabetic sort, for stability--- >     return max(self.classes, key=lambda label: (scores[label], label))----predict :: Perceptron -> Map Feature Int -> Maybe Class-predict per features = -- find highest ranked score in finalScores:-    -- trace ("features: "++ show features ++ "\n") $-    -- trace ("finalScores: "++ show sortedScores ++ "\n") $-    sortedScores-    where-      sortedScores :: Maybe Class-      sortedScores = fst $ Map.foldlWithKey ranker (Nothing, negate infinity) finalScores--      ranker r@(_, ow) nc nw | nw > ow   = (Just nc, nw)-                             | otherwise = r--      finalScores :: Map Class Weight-      finalScores = Map.foldlWithKey fn Map.empty features--      fn :: Map Class Weight -> Feature -> Int -> Map Class Weight-      fn scores f  v-         | v > 0 = case Map.lookup f (weights per) of-                     Just vec -> Map.foldlWithKey (doProd v) scores vec-                     Nothing  -> scores-         | otherwise = scores--      doProd :: Int -> Map Class Weight -> Class -> Weight -> Map Class Weight-      doProd value scores label weight =-        Map.alter (updater (weight * (fromIntegral value))) label scores--      updater :: Weight -> Maybe Weight -> Maybe Weight-      updater newVal Nothing  = Just newVal-      updater newVal (Just v) = Just (v + newVal)---- | Update the perceptron with a new example.------ > update(self, truth, guess, features)--- >    ...--- >         self.i += 1--- >         if truth == guess:--- >             return None--- >         for f in features:--- >             weights = self.weights.setdefault(f, {}) -- setdefault is Map.findWithDefault, and destructive.--- >             upd_feat(truth, f, weights.get(truth, 0.0), 1.0)--- >             upd_feat(guess, f, weights.get(guess, 0.0), -1.0)--- >         return None----update :: Perceptron -> Class -> Class -> [Feature] -> Perceptron-update per truth guess features-  | truth == guess = incrementInstances per-  | otherwise      = foldr loopBody per features-    where-      loopBody :: Feature -> Perceptron -> Perceptron-      loopBody f p = let-        fweights  = getFeatureWeight p f-        cweight c = Map.findWithDefault 0 c fweights-        in upd_feat guess f (cweight guess) (-1)-             (upd_feat truth f (cweight truth) 1 p)---- | ported from python:------ > def update(self, truth, guess, features):--- >        '''Update the feature weights.'''--- >        def upd_feat(c, f, w, v):--- >           param = (f, c)--- >           self._totals[param] += (self.i - self._tstamps[param]) * w--- >           self._tstamps[param] = self.i--- >           self.weights[f][c] = w + v-upd_feat :: Class -> Feature -> Weight -> Weight -> Perceptron -> Perceptron-upd_feat c f w v p = let-    newInstances = 1 + (instances p) -- increment the instance counter.--    -- self._totals[param] += (self.i - self._tstamps[param]) * w-    paramTstamp = newInstances - getTimestamp p (f, c)-    tmpTotal  = (getTotal p (f, c)) + ((fromIntegral paramTstamp) * w)-    newTotals = Map.insert (f, c) tmpTotal (totals p)--    -- self._tstamps[param] = self.i-    newTstamps = Map.insert (f, c) newInstances (tstamps p)--    -- self.weights[f][c] = w + v-    newWeights = Map.insert f (Map.insert c (w + v) (getFeatureWeight p f)) (weights p)--    in p { totals = newTotals-         , tstamps = newTstamps-         , weights = newWeights }----- | Average the weights------ Ported from Python:------ > def average_weights(self):--- >     for feat, weights in self.weights.items():--- >         new_feat_weights = {}--- >         for clas, weight in weights.items():--- >             param = (feat, clas)--- >             total = self._totals[param]--- >             total += (self.i - self._tstamps[param]) * weight--- >             averaged = round(total / float(self.i), 3)--- >             if averaged:--- >                 new_feat_weights[clas] = averaged--- >         self.weights[feat] = new_feat_weights--- >     return None----averageWeights :: Perceptron -> Perceptron-averageWeights per | (instances per) == 0 = per-                   | otherwise = per { weights = Map.mapWithKey avgWeights $ weights per-                                     , tstamps = Map.mapWithKey (\_ _->0) (tstamps per)-                                     , instances = 0 }-  where-    avgWeights :: Feature -> Map Class Weight -> Map Class Weight-    avgWeights feat ws = Map.foldlWithKey (doAvg feat) Map.empty ws--    doAvg :: Feature -> Map Class Weight -> Class -> Weight -> Map Class Weight-    doAvg f acc c w = let-      param = (f, c)-      paramTotal = instances per - getTimestamp per param--      total :: Weight-      total = (getTotal per param) + ((fromIntegral paramTotal) * w)-      averaged = roundTo 3 (total / (fromIntegral $ instances per))-      in if 0 == averaged-           then acc-           else Map.insert c averaged acc---- | round a fractional number to a specified decimal place.------ >>> roundTo 2 3.1459--- 3.15----roundTo :: RealFrac a => Int -> a -> a-roundTo n f = (fromInteger $ round $ f * (10^n)) / (10.0^^n)----- Train a perceptron------ Ported from Python:--- > def train(nr_iter, examples):--- >     model = Perceptron()--- >     for i in range(nr_iter):--- >         random.shuffle(examples)--- >         for features, class_ in examples:--- >             scores = model.predict(features)--- >             guess, score = max(scores.items(), key=lambda i: i[1])--- >             if guess != class_:--- >                 model.update(class_, guess, features)--- >     model.average_weights()--- >     return model-train :: Int -> Perceptron -> [(Map Feature Int, Class)] -> IO Perceptron-train itr model exs = do-  trainingSet <- shuffleM $ concat $ take itr $ repeat exs-  return $ averageWeights $ foldl' trainEx model trainingSet--trainEx :: Perceptron -> (Map Feature Int, Class) -> Perceptron-trainEx model (feats, truth) = let-  guess = fromMaybe (Class "Unk") $ predict model feats-  in update model truth guess $ Map.keys feats

@@ -20,9 +20,9 @@ where  import NLP.Corpora.Parsing (readPOSWith)-import NLP.POS.AvgPerceptron ( Perceptron, Feature(..)-                             , Class(..), predict, update-                             , emptyPerceptron, averageWeights)+import NLP.ML.AvgPerceptron ( Perceptron, Feature(..)+                            , Class(..), predict, update+                            , emptyPerceptron, averageWeights) import NLP.Types  import Control.Monad (foldM)

@@ -46,6 +46,8 @@   tagTerm :: a -> Text   startTag :: a   endTag :: a+  -- | Check if a tag is a determiner tag.+  isDt :: a -> Bool  -- | A fall-back 'ChunkTag' instance, analogous to 'RawTag' newtype RawChunk = RawChunk Text@@ -77,6 +79,8 @@    startTag = RawTag "-START-"   endTag = RawTag "-END-"++  isDt (RawTag tg) = tg == "DT"  instance Arbitrary RawTag where   arbitrary = do

@@ -46,6 +46,16 @@ data Chunk chunk tag = Chunk chunk [ChunkOr chunk tag]   deriving (Read, Show, Eq) +showChunkedSent :: (ChunkTag c, Tag t) => ChunkedSentence c t -> Text+showChunkedSent (ChunkedSent cs) = T.intercalate " " (map showChunkOr cs)+  where+    showChunkOr (POS_CN    pos)         = printPOS pos+    showChunkOr (Chunk_CN (Chunk chunk cors)) =+      let front = T.concat ["[", fromChunk chunk]+          back = "]"+          bits = map showChunkOr cors+      in T.append (T.intercalate " " (front:bits)) back+ instance (ChunkTag c, Arbitrary c, Arbitrary t, Tag t) =>   Arbitrary (ChunkedSentence c t) where   arbitrary = ChunkedSent <$> arbitrary

@@ -11,7 +11,7 @@ import Data.Map (Map) import qualified Data.Map as Map -import NLP.POS.AvgPerceptron+import NLP.ML.AvgPerceptron  tests :: Test tests = testGroup "AvgPerceptron"

@@ -31,6 +31,7 @@ import qualified NLP.Similarity.VectorSimTests as Vec import qualified NLP.TypesTests as TypeTests import qualified NLP.Types.IOBTests as IOB+import qualified NLP.Types.TreeTests as Tree import qualified NLP.Chunk.AvgPerceptronChunkerTests as APC  import Corpora@@ -69,6 +70,7 @@         , Conll.tests         , IOB.tests         , APC.tests+        , Tree.tests         ]