chatter (empty) → 0.0.0.1
raw patch · 20 files changed
+1773/−0 lines, 20 filesdep +HUnitdep +MonadRandomdep +QuickChecksetup-changed
Dependencies added: HUnit, MonadRandom, QuickCheck, base, bytestring, cereal, chatter, containers, criterion, filepath, fullstop, quickcheck-instances, random-shuffle, safe, split, test-framework, test-framework-hunit, test-framework-quickcheck2, test-framework-skip, text, zlib
Files
- LICENSE +29/−0
- Setup.hs +2/−0
- appsrc/Evaluate.hs +24/−0
- appsrc/Tagger.hs +22/−0
- appsrc/Trainer.hs +25/−0
- chatter.cabal +146/−0
- data/models/README +14/−0
- data/models/brown-train.model.gz too large to diff
- src/Data/DefaultMap.hs +39/−0
- src/NLP/Corpora/Parsing.hs +28/−0
- src/NLP/POS.hs +226/−0
- src/NLP/POS/AvgPerceptron.hs +266/−0
- src/NLP/POS/AvgPerceptronTagger.hs +325/−0
- src/NLP/POS/LiteralTagger.hs +54/−0
- src/NLP/POS/UnambiguousTagger.hs +64/−0
- src/NLP/Similarity/VectorSim.hs +99/−0
- src/NLP/Tokenize.hs +132/−0
- src/NLP/Types.hs +132/−0
- tests/src/Bench.hs +54/−0
- tests/src/Main.hs +92/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2013, Rogan Creswick+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++Neither the name of Rogan Creswick nor the names of his or her+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ appsrc/Evaluate.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Evaluate where++import qualified Data.Text as T+import qualified Data.Text.IO as T++import System.Environment (getArgs)++import NLP.Corpora.Parsing+import NLP.POS (eval, loadTagger)++main :: IO ()+main = do+ args <- getArgs+ let modelFile = args!!0+ corpora = tail args+ putStrLn "Loading model..."+ tagger <- loadTagger modelFile+ putStrLn "...model loaded."+ rawCorpus <- mapM T.readFile corpora+ let taggedCorpora = map readPOS $ concatMap T.lines $ rawCorpus+ result = eval tagger taggedCorpora+ putStrLn ("Result: " ++ show result)+ putStrLn ("Tokens tagged: "++(show $ length $ concat taggedCorpora))
+ appsrc/Tagger.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+module Tagger where++import qualified Data.ByteString as BS+import Data.Serialize (decode)+import qualified Data.Text as T+import qualified Data.Text.IO as T++import System.Environment (getArgs)++import NLP.POS (tagText, loadTagger)+import NLP.POS.AvgPerceptronTagger (mkTagger)++main :: IO ()+main = do+ args <- getArgs+ let modelFile = args!!0+ sentence = args!!1+ putStrLn "Loading model..."+ tagger <- loadTagger modelFile+ putStrLn "...model loaded."+ T.putStrLn $ tagText tagger (T.pack sentence)
+ appsrc/Trainer.hs view
@@ -0,0 +1,25 @@+{-# 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++main :: IO ()+main = do+ args <- getArgs+ let output = last args+ corpora = init args+ avgPerTagger = Avg.mkTagger Avg.emptyPerceptron Nothing+ 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+
+ chatter.cabal view
@@ -0,0 +1,146 @@+name: chatter+version: 0.0.0.1+synopsis: A library of simple NLP algorithms.+description: chatter is a collection of simple Natural Language+ Processing algorithms.+ .+ Chatter supports:+ .+ * Part of speech tagging with Averaged+ Perceptrons. Based on the Python implementation+ 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.+ .+ * Document similarity; A cosine-based similarity measure, and TF-IDF calculations,+ are available in the 'NLP.Similarity.VectorSim' module.+homepage: http://github.com/creswick/chatter+Bug-Reports: http://github.com/creswick/chatter/issues+category: Tools+license: BSD3+License-file: LICENSE+author: Rogan Creswick+maintainer: creswick@gmail.com+Cabal-Version: >=1.10+build-type: Simple++data-files: ./data/models/README+ ./data/models/brown-train.model.gz++source-repository head+ type: git+ location: git://github.com/creswick/chatter.git++Library+ default-language: Haskell2010+ hs-source-dirs: src++ Other-modules: Paths_chatter++ Exposed-modules: NLP.POS+ NLP.POS.AvgPerceptron+ NLP.POS.AvgPerceptronTagger+ NLP.POS.LiteralTagger+ NLP.POS.UnambiguousTagger+ NLP.Types+ NLP.Tokenize+ NLP.Corpora.Parsing+ NLP.Similarity.VectorSim+ Data.DefaultMap++ Build-depends: base >= 4 && <= 6,+ text,+ containers,+ safe,+ random-shuffle,+ MonadRandom,+ cereal,+ fullstop,+ split,+ bytestring,+ zlib,+ filepath++ ghc-options: -Wall+++Executable tag+ default-language: Haskell2010+ Main-Is: Tagger.hs+ hs-source-dirs: appsrc++ Build-depends: chatter,+ filepath,+ text,+ base >= 4 && <= 6,+ bytestring,+ cereal++ ghc-options: -Wall -main-is Tagger -rtsopts++Executable train+ default-language: Haskell2010+ Main-Is: Trainer.hs+ hs-source-dirs: appsrc++ Build-depends: chatter,+ filepath,+ text,+ base >= 4 && <= 6,+ bytestring,+ cereal,+ containers++ ghc-options: -Wall -main-is Trainer -rtsopts++Executable eval+ default-language: Haskell2010+ Main-Is: Evaluate.hs+ hs-source-dirs: appsrc++ Build-depends: chatter,+ filepath,+ text,+ base >= 4 && <= 6,+ bytestring,+ cereal,+ containers++ ghc-options: -Wall -main-is Evaluate -rtsopts++Executable bench+ default-language: Haskell2010+ Main-Is: Bench.hs+ hs-source-dirs: tests/src++ Build-depends: chatter,+ criterion,+ filepath,+ text,+ base >= 4 && <= 6,+ split++ ghc-options: -Wall -main-is Bench+++test-suite tests+ default-language: Haskell2010+ type: exitcode-stdio-1.0++ Main-Is: Main.hs+ hs-source-dirs: tests/src++ Build-depends: chatter,+ base >= 4 && <= 6,+ text,+ HUnit,+ test-framework,+ test-framework-skip,+ test-framework-quickcheck2,+ test-framework-hunit,+ QuickCheck < 2.6,+ filepath,+ cereal,+ quickcheck-instances,+ containers++ ghc-options: -Wall
+ data/models/README view
@@ -0,0 +1,14 @@+++brown-train.model.gz+---------------------------------------------------------------------++Averaged Perceptron tagger and Unambiguous Tagger trained on most of+the Brown corpus; the following files were held out for testing:++ ca01 ca03 cb02 cc01 cc03 cd02 ce01 ce03 cf02 cg01 cg03 ch02 cj01 cj03+ ck02 cl01 cl03 cm02 cn01 cn03 cp02 cr01 cr03 ca02 cb01 cb03 cc02 cd01+ cd03 ce02 cf01 cf03 cg02 ch01 ch03 cj02 ck01 ck03 cl02 cm01 cm03 cn02+ cp01 cp03 cr02++The remainder of the Brown corpus was used to train this model.
+ data/models/brown-train.model.gz view
file too large to diff
+ src/Data/DefaultMap.hs view
@@ -0,0 +1,39 @@+module Data.DefaultMap+where++import Data.Map (Map)+import qualified Data.Map as Map++-- | Defaulting Map; a Map that returns a default value when queried+-- for a key that does not exist.+data DefaultMap k v = DefMap { defDefault :: v+ , defMap :: Map k v+ } deriving (Read, Show, Eq, Ord)+++-- | Create an empty `DefaultMap`+empty :: v -> DefaultMap k v+empty def = DefMap { defDefault = def+ , defMap = Map.empty }++-- | Query the map for a value. Returns the default if the key is not+-- found.+lookup :: Ord k => k -> DefaultMap k v -> v+lookup k m = Map.findWithDefault (defDefault m) k (defMap m)++-- | Create a `DefaultMap` from a default value and a list.+fromList :: Ord k => v -> [(k, v)] -> DefaultMap k v+fromList def entries = DefMap { defDefault = def+ , defMap = Map.fromList entries }++-- | Access the keys as a list.+keys :: DefaultMap k a -> [k]+keys m = Map.keys (defMap m)++-- | Fold over the values in the map.+--+-- Note that this *does* not fold+-- over the default value -- this fold behaves in the same way as a+-- standard `Data.Map.foldl`+foldl :: (a -> b -> a) -> a -> DefaultMap k b -> a+foldl fn acc m = Map.foldl fn acc (defMap m)
+ src/NLP/Corpora/Parsing.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module NLP.Corpora.Parsing where++import qualified Data.Text as T+import Data.Text (Text)++import NLP.Types (Tag(..), parseTag, tagUNK, TaggedSentence)++-- | Read a POS-tagged corpus out of a Text string of the form:+-- "token\/tag token\/tag..."+--+-- >>> readPOS "Dear/jj Sirs/nns :/: Let/vb"+-- [("Dear",JJ),("Sirs",NNS),(":",Other ":"),("Let",VB)]+--+readPOS :: Text -> TaggedSentence+readPOS str = map toTagged $ T.words str+ where+ toTagged :: Text -> (Text, Tag)+ toTagged txt | "/" `T.isInfixOf` txt = let+ (tok, tagStr) = T.breakOnEnd "/" (T.strip txt)+ in (safeInit tok, parseTag tagStr)+ | otherwise = (txt, tagUNK)++-- | Returns all but the last element of a string, unless the string+-- is empty, in which case it returns that string.+safeInit :: Text -> Text+safeInit str | T.length str == 0 = str+ | otherwise = T.init str
+ src/NLP/POS.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module aims to make tagging text with parts of speech+-- trivially easy.+--+-- If you're new to 'chatter' and POS-tagging, then I+-- suggest you simply try:+--+-- >>> tagger <- defaultTagger+-- >>> tagStr tagger "This is a sample sentence."+-- "This/dt is/bez a/at sample/nn sentence/nn ./."+--+-- Note that we used 'tagStr', instead of 'tag', or 'tagText'. Many+-- people don't (yet!) use "Data.Text" by default, so there is a+-- wrapper around 'tag' that packs and unpacks the 'String'. This is+-- innefficient, but it's just to get you started, and 'tagStr' can be+-- very handy when you're debugging an tagger in ghci (or cabal repl).+--+-- 'tag' exposes more details of the tokenization and tagging, since+-- it returns a list of `TaggedSentence`s, but it doesn't print+-- results as nicely.+--+module NLP.POS+ ( tag+ , tagStr+ , tagText+ , train+ , trainStr+ , trainText+ , eval+ , serialize+ , deserialize+ , taggerTable+ , saveTagger+ , loadTagger+ , defaultTagger+ )+where+++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.Text (Text)+import qualified Data.Text as T+import Data.Serialize (encode, decode)+import Codec.Compression.GZip (decompress)+import System.FilePath ((</>))++import NLP.Corpora.Parsing (readPOS)++import NLP.Types (TaggedSentence, Tag(..)+ , POSTagger(..), tagUNK, stripTags)++import qualified NLP.POS.LiteralTagger as LT+import qualified NLP.POS.UnambiguousTagger as UT+import qualified NLP.POS.AvgPerceptronTagger as Avg++import Paths_chatter++defaultTagger :: IO POSTagger+defaultTagger = do+ dir <- getDataDir+ loadTagger (dir </> "data" </> "models" </> "brown-train.model.gz")++-- | 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.+taggerTable :: Map ByteString (ByteString -> Maybe POSTagger -> Either String POSTagger)+taggerTable = Map.fromList+ [ (LT.taggerID, LT.readTagger)+ , (Avg.taggerID, Avg.readTagger)+ , (UT.taggerID, UT.readTagger)+ ]++-- | Store a `POSTager' to a file.+saveTagger :: POSTagger -> FilePath -> IO ()+saveTagger tagger file = BS.writeFile file (serialize tagger)++-- | Load a tagger, using the interal `taggerTable`. If you need to+-- specify your own mappings for new composite taggers, you should use+-- `deserialize`.+--+-- This function checks the filename to determine if the content+-- should be decompressed. If the file ends with ".gz", then we+-- assume it is a gziped model.+loadTagger :: FilePath -> IO POSTagger+loadTagger file = do+ content <- getContent file+ case deserialize taggerTable content of+ Left err -> error err+ Right tgr -> return tgr+ where+ getContent :: FilePath -> IO ByteString+ getContent f | ".gz" `isSuffixOf` file = fmap (LBS.toStrict . decompress) $ LBS.readFile f+ | otherwise = BS.readFile f++serialize :: POSTagger -> ByteString+serialize tagger =+ let backoff = case posBackoff tagger of+ Nothing -> Nothing+ Just btgr -> Just $ serialize btgr+ in encode ( posID tagger+ , posSerialize tagger+ , backoff+ )++deserialize :: Map ByteString (ByteString -> Maybe POSTagger -> Either String POSTagger)+ -> ByteString+ -> Either String POSTagger+deserialize table bs = do+ (theID, theTgr, mBackoff) <- decode bs+ backoff <- case mBackoff of+ Nothing -> Right Nothing+ Just str -> Just `fmap` (deserialize table str)+ case Map.lookup theID table of+ Nothing -> Left ("Could not find ID in POSTagger function map: " ++ show theID)+ Just fn -> fn theTgr backoff++-- | Tag a chunk of input text with part-of-speech tags, using the+-- sentence splitter, tokenizer, and tagger contained in the 'POSTager'.+tag :: POSTagger -> Text -> [TaggedSentence]+tag p txt = let sentences = (posSplitter p) txt+ tokens = map (posTokenizer p) sentences+ priority = (posTagger p) tokens+ in case posBackoff p of+ Nothing -> priority+ Just tgr -> combine priority (tag tgr txt)++-- | Combine the results of POS taggers, using the second param to+-- fill in 'tagUNK' entries, where possible.+combine :: [TaggedSentence] -> [TaggedSentence] -> [TaggedSentence]+combine xs ys = zipWith combineSentences xs ys++combineSentences :: TaggedSentence -> TaggedSentence -> TaggedSentence+combineSentences xs ys = zipWith pickTag xs ys++-- | Returns the first param, unless it is tagged 'tagUNK'.+-- Throws an error if the text does not match.+pickTag :: (Text, Tag) -> (Text, Tag) -> (Text, Tag)+pickTag a@(txt1, t1) b@(txt2, t2) | txt1 /= txt2 = error ("Text does not match: "++ show a ++ " " ++ show b)+ | t1 /= tagUNK = (txt1, t1)+ | otherwise = (txt1, t2)++-- | Tag the tokens in a string.+--+-- Returns a space-separated string of tokens, each token suffixed+-- with the part of speech. For example:+--+-- >>> tag tagger "the dog jumped ."+-- "the/at dog/nn jumped/vbd ./."+--+tagStr :: POSTagger -> String -> String+tagStr tgr = T.unpack . tagText tgr . T.pack++-- | Text version of tagStr+tagText :: POSTagger -> Text -> Text+tagText tgr str = T.intercalate " " $ map toTaggedTok taggedSents+ where+ taggedSents = concat $ tag tgr str++ toTaggedTok :: (Text, Tag) -> Text+ toTaggedTok (tok, Tag c) = tok `T.append` (T.cons '/' c)++-- | Train a tagger on string input in the standard form for POS+-- tagged corpora:+--+-- > trainStr tagger "the/at dog/nn jumped/vbd ./."+--+trainStr :: POSTagger -> String -> IO POSTagger+trainStr tgr = trainText tgr . T.pack++-- | The `Text` version of `trainStr`+trainText :: POSTagger -> Text -> IO POSTagger+trainText p exs = train p (map readPOS $ (posTokenizer p) exs)++-- | Train a 'POSTagger' on a corpus of sentences.+--+-- This will recurse through the 'POSTagger' stack, training all the+-- backoff taggers as well. In order to do that, this function has to+-- be generic to the kind of taggers used, so it is not possible to+-- train up a new POSTagger from nothing: 'train' wouldn't know what+-- tagger to create.+--+-- To get around that restriction, you can use the various 'mkTagger'+-- implementations, such as 'NLP.POS.LiteralTagger.mkTagger' or+-- NLP.POS.AvgPerceptronTagger.mkTagger'. For example:+--+-- > import NLP.POS.AvgPerceptronTagger as APT+-- >+-- > let newTagger = APT.mkTagger APT.emptyPerceptron Nothing+-- > posTgr <- train newTagger trainingExamples+--+train :: POSTagger -> [TaggedSentence] -> IO POSTagger+train p exs = do+ let+ trainBackoff = case posBackoff p of+ Nothing -> return $ Nothing+ Just b -> do tgr <- train b exs+ return $ Just tgr+ trainer = posTrainer p+ newTgr <- trainer exs+ newBackoff <- trainBackoff+ return (newTgr { posBackoff = newBackoff })++-- | Evaluate a 'POSTager'.+--+-- Measures accuracy over all tags in the test corpus.+--+-- Accuracy is calculated as:+--+-- > |tokens tagged correctly| / |all tokens|+--+eval :: POSTagger -> [TaggedSentence] -> Double+eval tgr oracle = let+ sentences = map stripTags oracle+ results = (posTagger tgr) sentences+ totalTokens = fromIntegral $ sum $ map length oracle++ isMatch :: (Text, Tag) -> (Text, Tag) -> Double+ isMatch (_, rTag) (_, oTag) | rTag == oTag = 1+ | otherwise = 0+ in (sum $ zipWith isMatch (concat results) (concat oracle)) / totalTokens
+ src/NLP/POS/AvgPerceptron.hs view
@@ -0,0 +1,266 @@+{-# 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 Data.List (foldl')+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe)+import Data.Serialize (Serialize, put, get)+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 where+ put (Feat txt) = put txt+ get = fmap Feat get++-- | 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++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 = per { weights = Map.mapWithKey avgWeights $ weights per }+ 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
+ src/NLP/POS/AvgPerceptronTagger.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Avegeraged Perceptron Tagger+--+-- Adapted from the python implementation found here:+--+-- * <https://github.com/sloria/textblob-aptagger/blob/master/textblob_aptagger/taggers.py>+--+module NLP.POS.AvgPerceptronTagger+ ( mkTagger+ , trainNew+ , trainOnFiles+ , train+ , trainInt+ , tag+ , tagSentence+ , emptyPerceptron+ , taggerID+ , readTagger+ )+where++import NLP.Corpora.Parsing (readPOS)+import NLP.POS.AvgPerceptron ( Perceptron, Feature(..)+ , Class(..), predict, update+ , emptyPerceptron, averageWeights)+import NLP.Types++import Control.Monad (foldM)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 (pack)+import Data.List (zipWith4, foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Serialize (encode, decode)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T++import NLP.Tokenize (tokenize)+import NLP.FullStop (segment)+import System.Random.Shuffle (shuffleM)++taggerID :: ByteString+taggerID = pack "NLP.POS.AvgPerceptronTagger"++readTagger :: ByteString -> Maybe POSTagger -> Either String POSTagger+readTagger bs backoff = do+ model <- decode bs+ return $ mkTagger model backoff++-- | Create an Averaged Perceptron Tagger using the specified back-off+-- tagger as a fall-back, if one is specified.+--+-- This uses a tokenizer adapted from the 'tokenize' package for a+-- tokenizer, and Erik Kow's fullstop sentence segmenter+-- (<http://hackage.haskell.org/package/fullstop>) as a sentence+-- splitter.+mkTagger :: Perceptron -> Maybe POSTagger -> POSTagger+mkTagger per mTgr = POSTagger { posTagger = tag per+ , posTrainer = \exs -> do+ newPer <- trainInt itterations per exs+ return $ mkTagger newPer mTgr+ , posBackoff = mTgr+ , posTokenizer = tokenize+ , posSplitter = (map T.pack) . segment . T.unpack+ , posSerialize = encode per+ , posID = taggerID+ }++itterations :: Int+itterations = 5++-- | Train a new 'Perceptron'.+--+-- The training corpus should be a collection of sentences, one+-- sentence on each line, and with each token tagged with a part of+-- speech.+--+-- For example, the input:+--+-- > "The/DT dog/NN jumped/VB ./.\nThe/DT cat/NN slept/VB ./."+--+-- defines two training sentences.+--+-- >>> tagger <- trainNew "Dear/jj Sirs/nns :/: Let/vb\nUs/nn begin/vb\n"+-- >>> tag tagger $ map T.words $ T.lines "Dear sir"+-- "Dear/jj Sirs/nns :/: Let/vb"+--+trainNew :: Text -> IO Perceptron+trainNew rawCorpus = train emptyPerceptron rawCorpus++-- | Train a new 'Perceptron' on a corpus of files.+trainOnFiles :: [FilePath] -> IO Perceptron+trainOnFiles corpora = foldM step emptyPerceptron corpora+ where+ step :: Perceptron -> FilePath -> IO Perceptron+ step per path = do+ content <- T.readFile path+ train per content++-- | Add training examples to a perceptron.+--+-- >>> tagger <- train emptyPerceptron "Dear/jj Sirs/nns :/: Let/vb\nUs/nn begin/vb\n"+-- >>> tag tagger $ map T.words $ T.lines "Dear sir"+-- "Dear/jj Sirs/nns :/: Let/vb"+--+-- If you're using multiple input files, this can be useful to improve+-- performance (by folding over the files). For example, see `trainOnFiles`+--+train :: Perceptron -- ^ The inital model.+ -> Text -- ^ Training data; formatted with one sentence+ -- per line, and standard POS tags after each+ -- space-delimeted token.+ -> IO Perceptron+train per rawCorpus = do+ let corpora = map readPOS $ T.lines rawCorpus+ trainInt itterations per corpora++-- | start markers to ensure all features in context are valid,+-- even for the first "real" tokens.+startToks :: [Text]+startToks = ["-START-", "-START2-"]++-- | end markers to ensure all features are valid, even for+-- the last "real" tokens.+endToks :: [Text]+endToks = ["-END-", "-END2-"]++-- | Tag a document (represented as a list of 'Sentence's) with a+-- trained 'Perceptron'+--+-- Ported from Python:+--+-- > def tag(self, corpus, tokenize=True):+-- > '''Tags a string `corpus`.'''+-- > # Assume untokenized corpus has \n between sentences and ' ' between words+-- > s_split = nltk.sent_tokenize if tokenize else lambda t: t.split('\n')+-- > w_split = nltk.word_tokenize if tokenize else lambda s: s.split()+-- > def split_sents(corpus):+-- > for s in s_split(corpus):+-- > yield w_split(s)+-- > prev, prev2 = self.START+-- > tokens = []+-- > for words in split_sents(corpus):+-- > context = self.START + [self._normalize(w) for w in words] + self.END+-- > for i, word in enumerate(words):+-- > tag = self.tagdict.get(word)+-- > if not tag:+-- > features = self._get_features(i, word, context, prev, prev2)+-- > tag = self.model.predict(features)+-- > tokens.append((word, tag))+-- > prev2 = prev+-- > prev = tag+-- > return tokens+--+tag :: Perceptron -> [Sentence] -> [TaggedSentence]+tag per corpus = map (tagSentence per) corpus++-- | Tag a single sentence.+tagSentence :: Perceptron -> Sentence -> TaggedSentence+tagSentence per sent = let++ tags = (map (Class . T.unpack) startToks) ++ map (predictPos per) features++ features = zipWith4 (getFeatures sent)+ [0..]+ sent+ (tail tags)+ tags++ in zip sent (map (\(Class c) ->Tag $ T.pack c) $ drop 2 tags)++-- | Train a model from sentences.+--+-- Ported from Python:+--+-- > def train(self, sentences, save_loc=None, nr_iter=5):+-- > self._make_tagdict(sentences)+-- > self.model.classes = self.classes+-- > prev, prev2 = START+-- > for iter_ in range(nr_iter):+-- > c = 0+-- > n = 0+-- > for words, tags in sentences:+-- > context = START + [self._normalize(w) for w in words] + END+-- > for i, word in enumerate(words):+-- > guess = self.tagdict.get(word)+-- > if not guess:+-- > feats = self._get_features(i, word, context, prev, prev2)+-- > guess = self.model.predict(feats)+-- > self.model.update(tags[i], guess, feats)+-- > prev2 = prev; prev = guess+-- > c += guess == tags[i]+-- > n += 1+-- > random.shuffle(sentences)+-- > logging.info("Iter {0}: {1}/{2}={3}".format(iter_, c, n, _pc(c, n)))+-- > self.model.average_weights()+-- > # Pickle as a binary file+-- > if save_loc is not None:+-- > pickle.dump((self.model.weights, self.tagdict, self.classes),+-- > open(save_loc, 'wb'), -1)+-- > return None+--+trainInt :: 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.+ -> [TaggedSentence] -- ^ 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 unzip examples++toClassLst :: [(Sentence, [Tag])] -> [(Sentence, [Class])]+toClassLst tagged = map (\(x, y)->(x, map (Class . T.unpack . fromTag) y)) tagged++trainCls :: Int -> Perceptron -> [(Sentence, [Class])] -> IO Perceptron+trainCls itr per examples = do+ trainingSet <- shuffleM $ concat $ take itr $ repeat examples+ return $ averageWeights $ foldl' trainSentence per trainingSet+++-- | Train on one sentence.+--+-- Adapted from this portion of the Python train method:+--+-- > context = START + [self._normalize(w) for w in words] + END+-- > for i, word in enumerate(words):+-- > guess = self.tagdict.get(word)+-- > if not guess:+-- > feats = self._get_features(i, word, context, prev, prev2)+-- > guess = self.model.predict(feats)+-- > self.model.update(tags[i], guess, feats)+-- > prev2 = prev; prev = guess+-- > c += guess == tags[i]+-- > n += 1+trainSentence :: Perceptron -> (Sentence, [Class]) -> Perceptron+trainSentence per (sent, ts) = let++ tags = (map (Class . T.unpack) startToks) ++ ts ++ (map (Class . T.unpack) endToks)++ features = zipWith4 (getFeatures sent)+ [0..] -- index+ sent -- words+ (tail tags) -- prev1+ tags -- prev2++ fn :: Perceptron -> (Map Feature Int, Class) -> Perceptron+ fn model (feats, truth) = let+ guess = predictPos model feats+ in update model truth guess $ Map.keys feats++ in foldl' fn per (zip features ts)++-- | Predict a Part of Speech, defaulting to the @Unk@ tag, if no+-- classification is found.+predictPos :: Perceptron -> Map Feature Int -> Class+predictPos model feats = fromMaybe (Class "Unk") $ predict model feats++-- | Default feature set.+--+-- > def _get_features(self, i, word, context, prev, prev2):+-- > '''Map tokens into a feature representation, implemented as a+-- > {hashable: float} dict. If the features change, a new model must be+-- > trained.+-- > '''+-- > def add(name, *args):+-- > features[' '.join((name,) + tuple(args))] += 1+-- > i += len(self.START)+-- > features = defaultdict(int)+-- > # It's useful to have a constant feature, which acts sort of like a prior+-- > add('bias')+-- > add('i suffix', word[-3:])+-- > add('i pref1', word[0])+-- > add('i-1 tag', prev)+-- > add('i-2 tag', prev2)+-- > add('i tag+i-2 tag', prev, prev2)+-- > add('i word', context[i])+-- > add('i-1 tag+i word', prev, context[i])+-- > add('i-1 word', context[i-1])+-- > add('i-1 suffix', context[i-1][-3:])+-- > add('i-2 word', context[i-2])+-- > add('i+1 word', context[i+1])+-- > add('i+1 suffix', context[i+1][-3:])+-- > add('i+2 word', context[i+2])+-- > return features+--+getFeatures :: [Text] -> Int -> Text -> Class -> Class -> Map Feature Int+getFeatures ctx idx word prev prev2 = let+ context = startToks ++ ctx ++ endToks++ i = idx + 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 = [ ["bias", ""]+ , ["i suffix", suffix word ]+ , ["i pref1", T.take 1 word ]+ , ["i-1 tag", T.pack $ show prev ]+ , ["i-2 tag", T.pack $ show prev2 ]+ , ["i tag+i-2 tag", T.pack $ show prev, T.pack $ show prev2 ]+ , ["i word", context!!i ]+ , ["i-1 tag+i word", T.pack $ show prev, context!!i ]+ , ["i-1 word", context!!(i-1) ]+ , ["i-1 suffix", suffix (context!!(i-1)) ]+ , ["i-2 word", context!!(i-2) ]+ , ["i+1 word", context!!(i+1) ]+ , ["i+1 suffix", suffix (context!!(i+1)) ]+ , ["i+2 word", context!!(i+2) ]+ ]+ -- in trace ("getFeatures: "++show (ctx, idx, word, prev, prev2)) $+ in foldl' add Map.empty features++mkFeature :: Text -> Feature+mkFeature txt = Feat $ T.copy txt++suffix :: Text -> Text+suffix str | T.length str <= 3 = str+ | otherwise = T.drop (T.length str - 3) str
+ src/NLP/POS/LiteralTagger.hs view
@@ -0,0 +1,54 @@+module NLP.POS.LiteralTagger+ ( tag+ , tagSentence+ , mkTagger+ , taggerID+ , readTagger+ )+where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 (pack)+import qualified Data.Map.Strict as Map+import Data.Serialize (encode, decode)+import Data.Map.Strict (Map)+import Data.Text (Text)+import qualified Data.Text as T++import NLP.Tokenize (tokenize)+import NLP.FullStop (segment)+import NLP.Types ( tagUNK, Sentence, TaggedSentence+ , Tag, POSTagger(..))++taggerID :: ByteString+taggerID = pack "NLP.POS.LiteralTagger"++-- | Create a Literal Tagger using the specified back-off tagger as a+-- fall-back, if one is specified.+--+-- This uses a tokenizer adapted from the 'tokenize' package for a+-- tokenizer, and Erik Kow's fullstop sentence segmenter as a sentence+-- splitter.+mkTagger :: Map Text Tag -> Maybe POSTagger -> POSTagger+mkTagger table mTgr = POSTagger { posTagger = tag table+ , posTrainer = \_ -> return $ mkTagger table mTgr+ , posBackoff = mTgr+ , posTokenizer = tokenize+ , posSplitter = (map T.pack) . segment . T.unpack+ , posSerialize = encode table+ , posID = taggerID+ }++tag :: Map Text Tag -> [Sentence] -> [TaggedSentence]+tag table ss = map (tagSentence table) ss++tagSentence :: Map Text Tag -> Sentence -> TaggedSentence+tagSentence table toks = map findTag toks+ where+ findTag :: Text -> (Text, Tag)+ findTag txt = (txt, Map.findWithDefault tagUNK txt table)++readTagger :: ByteString -> Maybe POSTagger -> Either String POSTagger+readTagger bs backoff = do+ model <- decode bs+ return $ mkTagger model backoff
+ src/NLP/POS/UnambiguousTagger.hs view
@@ -0,0 +1,64 @@+-- | This POS tagger deterministically tags tokens. However, if it+-- ever sees multiple tags for the same token, it will forget the tag+-- it has learned. This is useful for creating taggers that have very+-- high precision, but very low recall.+--+-- Unambiguous taggers are also useful when defined with a+-- non-deterministic backoff tagger, such as an+-- "NLP.POS.AveragedPerceptronTagger", since the high-confidence tags+-- will be applied first, followed by the more non-deterministic+-- results of the backoff tagger.+module NLP.POS.UnambiguousTagger where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 (pack)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Serialize (encode, decode)+import Data.Text (Text)++import NLP.Types++import qualified NLP.POS.LiteralTagger as LT++taggerID :: ByteString+taggerID = pack "NLP.POS.UnambiguousTagger"++readTagger :: ByteString -> Maybe POSTagger -> Either String POSTagger+readTagger bs backoff = do+ model <- decode bs+ return $ mkTagger model backoff++-- | Create an unambiguous tagger, using the supplied 'Map' as a+-- source of tags.+mkTagger :: Map Text Tag -> Maybe POSTagger -> POSTagger+mkTagger table mTgr = let+ litTagger = LT.mkTagger table mTgr++ trainer :: [TaggedSentence] -> IO POSTagger+ trainer exs = do+ let newTable = train table exs+ return $ mkTagger newTable mTgr++ in litTagger { posTrainer = trainer+ , posSerialize = encode table+ , posID = taggerID+ }++-- | Trainer method for unambiguous taggers.+train :: Map Text Tag -> [TaggedSentence] -> Map Text Tag+train table exs = let+ pairs :: [(Text, Tag)]+ pairs = concat exs++ trainOnPair :: Map Text Tag -> (Text, Tag) -> Map Text Tag+ trainOnPair t (txt, tag) = Map.alter (incorporate tag) txt t++ incorporate :: Tag -> Maybe Tag -> Maybe Tag+ incorporate new Nothing = Just new+ incorporate new (Just old) | new == old = Just old+ | otherwise = Nothing++ in foldl trainOnPair table pairs++
+ src/NLP/Similarity/VectorSim.hs view
@@ -0,0 +1,99 @@+module NLP.Similarity.VectorSim where++import Data.DefaultMap (DefaultMap)+import qualified Data.DefaultMap as DM+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.List (elemIndices)++import NLP.Types++-- | An efficient (ish) representation for documents in the "bag of+-- words" sense.+type TermVector = DefaultMap Text Double++-- | Generate a `TermVector` from a tokenized document.+mkVector :: Corpus -> [Text] -> TermVector+mkVector corpus doc = DM.fromList 0 $ Set.toList $+ Set.map (\t->(t, tf_idf t doc corpus)) (Set.fromList doc)+++-- | Invokes similarity on full strings, using `T.words` for+-- tokenization, and no stemming.+--+-- There *must* be at least one document in the corpus.+sim :: Corpus -> Text -> Text -> Double+sim corpus doc1 doc2 = similarity corpus (T.words doc1) (T.words doc2)++-- | Determine how similar two documents are.+--+-- This function assumes that each document has been tokenized and (if+-- desired) stemmed/case-normalized.+--+-- This is a wrapper around `tvSim`, which is a *much* more efficient+-- implementation. If you need to run similarity against any single+-- document more than once, then you should create `TermVector`s for+-- each of your documents and use `tvSim` instead of `similarity`.+--+-- There *must* be at least one document in the corpus.+similarity :: Corpus -> [Text] -> [Text] -> Double+similarity corpus doc1 doc2 = let+ vec1 = mkVector corpus doc1+ vec2 = mkVector corpus doc2+ in tvSim vec1 vec2++-- | Determine how similar two documents are.+--+-- Calculates the similarity between two documents, represented as+-- `TermVectors`+tvSim :: TermVector -> TermVector -> Double+tvSim doc1 doc2 = let+ theCos = cosVec doc1 doc2+ in if isNaN theCos then 0 else theCos++-- | Return the raw frequency of a term in a body of text.+--+-- The firt argument is the term to find, the second is a tokenized+-- document. This function does not do any stemming or additional text+-- modification.+tf :: Eq a => a -> [a] -> Int+tf term doc = length $ elemIndices term doc++-- | Calculate the inverse document frequency.+--+-- The IDF is, roughly speaking, a measure of how popular a term is.+idf :: Text -> Corpus -> Double+idf term corpus = let+ docCount = corpLength corpus+ containedInCount = 1 + termCounts corpus term+ in log (fromIntegral docCount / fromIntegral containedInCount)++-- | Calculate the tf*idf measure for a term given a document and a+-- corpus.+tf_idf :: Text -> [Text] -> Corpus -> Double+tf_idf term doc corp = let+ corpus = addDocument corp doc+ freq = tf term doc+ result | freq == 0 = 0+ | otherwise = (fromIntegral freq) * idf term corpus+ in result++cosVec :: TermVector -> TermVector -> Double+cosVec vec1 vec2 = let+ dp = dotProd vec1 vec2+ mag = (magnitude vec1 * magnitude vec2)+ in dp / mag++-- | Calculate the magnitude of a vector.+magnitude :: TermVector -> Double+magnitude v = sqrt $ DM.foldl acc 0 v+ where+ acc :: Double -> Double -> Double+ acc cur new = cur + (new ** 2)++-- | find the dot product of two vectors.+dotProd :: TermVector -> TermVector -> Double+dotProd xs ys = let+ terms = Set.fromList (DM.keys xs) `Set.union` Set.fromList (DM.keys ys)+ in Set.foldl (+) 0 (Set.map (\t -> (DM.lookup t xs) * (DM.lookup t ys)) terms)
+ src/NLP/Tokenize.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}+-- | NLP Tokenizer, adapted to use Text instead of Strings from the+-- `tokenize` package:+-- * http://hackage.haskell.org/package/tokenize-0.1.3+module NLP.Tokenize+ ( EitherList(..)+ , Tokenizer+ , tokenize+ , run+ , defaultTokenizer+ , whitespace+ , uris+ , punctuation+ , finalPunctuation+ , initialPunctuation+ , contractions+ , negatives+ )+where++import qualified Data.Char as Char+import Data.Maybe+import Control.Monad.Instances ()+import Control.Monad++import Data.Text (Text)+import qualified Data.Text as T++-- | A Tokenizer is function which takes a list and returns a list of Eithers+-- (wrapped in a newtype). Right Strings will be passed on for processing+-- to tokenizers down+-- the pipeline. Left Strings will be passed through the pipeline unchanged.+-- Use a Left String in a tokenizer to protect certain tokens from further +-- processing (e.g. see the 'uris' tokenizer).+type Tokenizer = Text -> EitherList Text Text++-- | The EitherList is a newtype-wrapped list of Eithers.+newtype EitherList a b = E { unE :: [Either a b] }++-- | Split string into words using the default tokenizer pipeline +tokenize :: Text -> [Text]+tokenize = run defaultTokenizer++-- | Run a tokenizer+run :: Tokenizer -> (Text -> [Text])+run f = \txt -> map T.copy $ (map unwrap . unE . f) txt++defaultTokenizer :: Tokenizer+defaultTokenizer = whitespace + >=> uris + >=> hyphens+ >=> punctuation + >=> contractions + >=> negatives ++-- | Detect common uris and freeze them+uris :: Tokenizer+uris x | isUri x = E [Left x]+ | True = E [Right x]+ where isUri u = any (`T.isPrefixOf` u) ["http://","ftp://","mailto:"]++-- | Split off initial and final punctuation+punctuation :: Tokenizer +punctuation = finalPunctuation >=> initialPunctuation++hyphens :: Tokenizer+hyphens xs = E [Right w | w <- T.split (=='-') xs ]++-- | Split off word-final punctuation+finalPunctuation :: Tokenizer+finalPunctuation x = E $ filter (not . T.null . unwrap) res+ where+ res :: [Either Text Text]+ res = case T.span Char.isPunctuation (T.reverse x) of+ (ps, w) | T.null ps -> [ Right $ T.reverse w ]+ | otherwise -> [ Right $ T.reverse w+ , Right $ T.reverse ps]+ -- ([],w) -> [Right . T.reverse $ w]+ -- (ps,w) -> [Right . T.reverse $ w, Right . T.reverse $ ps]++-- | Split off word-initial punctuation+initialPunctuation :: Tokenizer+initialPunctuation x = E $ filter (not . T.null . unwrap) $+ case T.span Char.isPunctuation x of+ (ps,w) | T.null ps -> [ Right w ]+ | otherwise -> [ Right ps+ , Right w ]++-- | Split words ending in n't, and freeze n't +negatives :: Tokenizer+negatives x | "n't" `T.isSuffixOf` x = E [ Right . T.reverse . T.drop 3 . T.reverse $ x+ , Left "n't" ]+ | True = E [ Right x ]++-- | Split common contractions off and freeze them.+-- | Currently deals with: 'm, 's, 'd, 've, 'll+contractions :: Tokenizer+contractions x = case catMaybes . map (splitSuffix x) $ cts of+ [] -> return x+ ((w,s):_) -> E [ Right w,Left s]+ where cts = ["'m","'s","'d","'ve","'ll"]+ splitSuffix w sfx = + let w' = T.reverse w+ len = T.length sfx+ in if sfx `T.isSuffixOf` w + then Just (T.take (T.length w - len) w, T.reverse . T.take len $ w')+ else Nothing+++-- | Split string on whitespace. This is just a wrapper for Data.List.words+whitespace :: Tokenizer+whitespace xs = E [Right w | w <- T.words xs ]++instance Monad (EitherList a) where+ return x = E [Right x]+ E xs >>= f = E $ concatMap (either (return . Left) (unE . f)) xs++unwrap :: Either a a -> a+unwrap (Left x) = x+unwrap (Right x) = x++examples :: [Text]+examples = + ["This shouldn't happen."+ ,"Some 'quoted' stuff"+ ,"This is a URL: http://example.org."+ ,"How about an email@example.com"+ ,"ReferenceError #1065 broke my debugger!"+ ,"I would've gone."+ ,"They've been there."+ ]+
+ src/NLP/Types.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module NLP.Types+where++import Data.ByteString (ByteString)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Serialize (Serialize, put, get)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import GHC.Generics++type Sentence = [Text]+type TaggedSentence = [(Text, Tag)]+++-- | Part of Speech tagger, with back-off tagger.+--+-- A sequence of pos taggers can be assembled by using backoff+-- taggers. When tagging text, the first tagger is run on the input,+-- possibly tagging some tokens as unknown ('Tag "Unk"'). The first+-- backoff tagger is then recursively invoked on the text to fill in+-- the unknown tags, but that may still leave some tokens marked with+-- 'Tag "Unk"'. This process repeats until no more taggers are found.+-- (The current implementation is not very efficient in this+-- respect.).+--+-- Back off taggers are particularly useful when there is a set of+-- domain specific vernacular that a general purpose statistical+-- tagger does not know of. A LitteralTagger can be created to map+-- terms to fixed POS tags, and then delegate the bulk of the text to+-- a statistical back off tagger, such as an AvgPerceptronTagger.+--+-- `POSTagger` values can be serialized and deserialized by using+-- `NLP.POS.serialize` and NLP.POS.deserialize`. This is a bit tricky+-- because the POSTagger abstracts away the implementation details of+-- the particular tagging algorithm, and the model for that tagger (if+-- any). To support serialization, each POSTagger value must provide+-- a serialize value that can be used to generate a `ByteString`+-- representation of the model, as well as a unique id (also a+-- `ByteString`). Furthermore, that ID must be added to a `Map+-- ByteString (ByteString -> Maybe POSTagger -> Either String+-- POSTagger)` that is provided to `deserialize`. The function in the+-- map takes the output of `posSerialize`, and possibly a backoff+-- tagger, and reconstitutes the POSTagger that was serialized+-- (assigning the proper functions, setting up closures as needed,+-- etc.) Look at the source for `NLP.POS.taggerTable` and+-- `NLP.POS.UnambiguousTagger.readTagger` for examples.+--+data POSTagger = POSTagger+ { posTagger :: [Sentence] -> [TaggedSentence] -- ^ The initial part-of-speech tagger.+ , posTrainer :: [TaggedSentence] -> IO POSTagger -- ^ Training function to train the immediate POS tagger.+ , posBackoff :: Maybe POSTagger -- ^ A tagger to invoke on unknown tokens.+ , posTokenizer :: Text -> Sentence -- ^ A tokenizer; (`Data.Text.words` will work.)+ , posSplitter :: Text -> [Text] -- ^ A sentence splitter. If your input is formatted as+ -- one sentence per line, then use `Data.Text.lines`,+ -- otherwise try Erik Kow's fullstop library.+ , posSerialize :: ByteString -- ^ Store this POS tagger to a+ -- bytestring. This does /not/+ -- serialize the backoff taggers.+ , posID :: ByteString -- ^ A unique id that will identify the+ -- algorithm used for this POS Tagger. This+ -- is used in deserialization+ }++-- | Remove the tags from a tagged sentence+stripTags :: TaggedSentence -> Sentence+stripTags = map fst++newtype Tag = Tag Text+ deriving (Ord, Eq, Read, Show, Generic)++instance Serialize Tag++fromTag :: Tag -> Text+fromTag (Tag t) = t++parseTag :: Text -> Tag+parseTag t = Tag t++-- | Constant tag for "unknown"+tagUNK :: Tag+tagUNK = Tag "Unk"++instance Serialize Text where+ put txt = put $ encodeUtf8 txt+ get = fmap decodeUtf8 get++-- | Document corpus.+--+-- This is a simple hashed corpus, the document content is not stored.+data Corpus = Corpus { corpLength :: Int+ -- ^ The number of documents in the corpus.+ , corpTermCounts :: Map Text Int+ -- ^ A count of the number of documents each term occurred in.+ } deriving (Read, Show, Eq, Ord)++-- | Get the number of documents that a term occurred in.+termCounts :: Corpus -> Text -> Int+termCounts corpus term = Map.findWithDefault 0 term $ corpTermCounts corpus++-- | Add a document to the corpus.+--+-- This can be dangerous if the documents are pre-processed+-- differently. All corpus-related functions assume that the+-- documents have all been tokenized and the tokens normalized, in the+-- same way.+addDocument :: Corpus -> [Text] -> Corpus+addDocument (Corpus count m) doc = Corpus (count + 1) (foldl addTerm m doc)++-- | Create a corpus from a list of documents, represented by+-- normalized tokens.+mkCorpus :: [[Text]] -> Corpus+mkCorpus docs =+ let docSets = map Set.fromList docs+ in Corpus { corpLength = length docs+ , corpTermCounts = foldl addTerms Map.empty docSets+ }++addTerms :: Map Text Int -> Set Text -> Map Text Int+addTerms m terms = Set.foldl addTerm m terms++addTerm :: Map Text Int -> Text -> Map Text Int+addTerm m term = Map.alter increment term m+ where+ increment :: Maybe Int -> Maybe Int+ increment Nothing = Just 1+ increment (Just i) = Just (i + 1)
+ tests/src/Bench.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+module Bench where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Criterion.Main+import Criterion.Config (defaultConfig, Config(..), ljust)+import Criterion (bench, bgroup, Benchmark)++import NLP.POS (tagText)+import NLP.POS.AvgPerceptronTagger (trainNew, mkTagger)+import Corpora++import qualified NLP.Similarity.VectorSimBench as VS++myConfig :: Config+myConfig = defaultConfig {+ -- Always GC between runs.+ cfgPerformGC = ljust True+ }++main :: IO ()+main = do+-- postagBench <- posTagging+ muc3_1 <- VS.muc3_01+ muc3_2 <- VS.muc3_02+ muc3_3 <- VS.muc3_03+ defaultMainWith myConfig (return ())+ [ bgroup "POS Tagging" [] -- postagBench+ , bgroup "Similarity" $ VS.benchmarks (muc3_1++muc3_2) muc3_3+ ]++-- posTagging :: IO [Benchmark]+-- posTagging = do+-- ca01 <- T.readFile brownCA01+-- ca02 <- T.readFile (brownCAFiles!!1)+-- let ca1_2 = T.unlines [ca01, ca02]+-- return [ bench "Train Brown ca01" $ trainNew ca01+-- , bench "Train & test Brown ca01" $ trainAndTag ca01 "the dog jumped"++-- , bench "Train Brown ca02" $ trainNew ca02+-- , bench "Train & test Brown ca02" $ trainAndTag ca02 "the dog jumped"++-- , bench "Train Brown ca01-02" $ trainNew ca1_2+-- , bench "Train & test Brown ca01-02" $ trainAndTag ca1_2 "the dog jumped"+-- ]++trainAndTag :: Text -> Text -> IO Text+trainAndTag corpus input = do+ tagger <- trainNew corpus+ return $ tagText (mkTagger tagger Nothing) input+
+ tests/src/Main.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Test.HUnit ( (@=?) )+import Test.QuickCheck ()+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework ( buildTest, testGroup, Test, defaultMain )+import Test.Framework.Skip (skip)++import NLP.Types (Tag(..), parseTag)+import NLP.POS (tagText, train)+import NLP.Corpora.Parsing (readPOS)++import qualified NLP.POS.AvgPerceptronTagger as APT+import qualified AvgPerceptronTests as APT+import qualified BackoffTaggerTests as Backoff+import qualified NLP.Similarity.VectorSimTests as Vec+import qualified NLP.POSTests as POS+import qualified NLP.POS.UnambiguousTaggerTests as UT++import Corpora++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests = [ testGroup "parseTag" $+ [ testProperty "basic tag parsing" prop_parseTag]+ , testGroup "Train and tag"+ [ testGroup "miniCorpora1" $+ map (trainAndTagTest miniCorpora1)+ [ ("the dog jumped .", "the/DT dog/NN jumped/VB ./.") ]+ , testGroup "miniCorpora2" $+ map (trainAndTagTest miniCorpora1)+ [ ("the dog jumped .", "the/DT dog/NN jumped/VB ./.") ]+ , testGroup "miniCorpora1 - POSTagger train" $+ map (trainAndTagTestVTrainer miniCorpora1)+ [ ("the dog jumped .", "the/DT dog/NN jumped/VB ./.") ]+ , 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+ , Vec.tests+ , POS.tests+ , UT.tests+ ]+++trainAndTagTestFileCorpus :: FilePath -> (Text, Text) -> Test+trainAndTagTestFileCorpus file args = buildTest $ do+ corpus <- T.readFile file+ return $ trainAndTagTest corpus args++trainAndTagTestIO :: IO Text -> (Text, Text) -> Test+trainAndTagTestIO corpora (input, oracle) = testCase (T.unpack input) $ do+ tagger <- APT.trainNew =<< corpora+ oracle @=? tagText (APT.mkTagger tagger Nothing) input++trainAndTagTest :: Text -> (Text, Text) -> Test+trainAndTagTest corpora (input, oracle) = testCase (T.unpack input) $ do+ tagger <- APT.trainNew corpora+ oracle @=? tagText (APT.mkTagger tagger Nothing) input++trainAndTagTestVTrainer :: Text -> (Text, Text) -> Test+trainAndTagTestVTrainer corpora (input, oracle) = testCase (T.unpack input) $ do+ let newTagger = APT.mkTagger APT.emptyPerceptron Nothing+ examples = map readPOS $ T.lines corpora+ posTgr <- train newTagger examples++ oracle @=? tagText posTgr input++prop_parseTag :: Text -> Bool+prop_parseTag txt = parseTag txt == Tag txt++genTest :: (Show a, Show b, Eq b) => (a -> b) -> (String, a, b) -> Test+genTest fn (descr, input, oracle) =+ testCase (descr++" input: "++show input) assert+ where assert = oracle @=? fn input