diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/appsrc/Evaluate.hs b/appsrc/Evaluate.hs
new file mode 100644
--- /dev/null
+++ b/appsrc/Evaluate.hs
@@ -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))
diff --git a/appsrc/Tagger.hs b/appsrc/Tagger.hs
new file mode 100644
--- /dev/null
+++ b/appsrc/Tagger.hs
@@ -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)
diff --git a/appsrc/Trainer.hs b/appsrc/Trainer.hs
new file mode 100644
--- /dev/null
+++ b/appsrc/Trainer.hs
@@ -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
+
diff --git a/chatter.cabal b/chatter.cabal
new file mode 100644
--- /dev/null
+++ b/chatter.cabal
@@ -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:
+ () 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
diff --git a/data/models/README b/data/models/README
new file mode 100644
--- /dev/null
+++ b/data/models/README
@@ -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.
diff --git a/data/models/brown-train.model.gz b/data/models/brown-train.model.gz
new file mode 100644
# file too large to diff: data/models/brown-train.model.gz
diff --git a/src/Data/DefaultMap.hs b/src/Data/DefaultMap.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/DefaultMap.hs
@@ -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)
diff --git a/src/NLP/Corpora/Parsing.hs b/src/NLP/Corpora/Parsing.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/Corpora/Parsing.hs
@@ -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
diff --git a/src/NLP/POS.hs b/src/NLP/POS.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/POS.hs
@@ -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
diff --git a/src/NLP/POS/AvgPerceptron.hs b/src/NLP/POS/AvgPerceptron.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/POS/AvgPerceptron.hs
@@ -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:
+--
+-- *
+--
+-- The Perceptron code can be found on github:
+--
+-- *
+--
+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
diff --git a/src/NLP/POS/AvgPerceptronTagger.hs b/src/NLP/POS/AvgPerceptronTagger.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/POS/AvgPerceptronTagger.hs
@@ -0,0 +1,325 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Avegeraged Perceptron Tagger
+--
+-- Adapted from the python implementation found here:
+--
+-- *
+--
+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
+-- () 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
diff --git a/src/NLP/POS/LiteralTagger.hs b/src/NLP/POS/LiteralTagger.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/POS/LiteralTagger.hs
@@ -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
diff --git a/src/NLP/POS/UnambiguousTagger.hs b/src/NLP/POS/UnambiguousTagger.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/POS/UnambiguousTagger.hs
@@ -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
+
+
diff --git a/src/NLP/Similarity/VectorSim.hs b/src/NLP/Similarity/VectorSim.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/Similarity/VectorSim.hs
@@ -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)
diff --git a/src/NLP/Tokenize.hs b/src/NLP/Tokenize.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/Tokenize.hs
@@ -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."
+ ]
+
diff --git a/src/NLP/Types.hs b/src/NLP/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/Types.hs
@@ -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)
diff --git a/tests/src/Bench.hs b/tests/src/Bench.hs
new file mode 100644
--- /dev/null
+++ b/tests/src/Bench.hs
@@ -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
+
diff --git a/tests/src/Main.hs b/tests/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/tests/src/Main.hs
@@ -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