sequor 0.4.2 → 0.7.0
raw patch · 20 files changed
+1064/−975 lines, 20 filesdep +nlp-scoresdep +split
Dependencies added: nlp-scores, split
Files
- README.rst +23/−9
- lib/Helper/ListZipper.hs +1/−0
- sequor.cabal +33/−12
- src/Config.hs +0/−39
- src/CorpusReader.hs +0/−43
- src/FeatureTemplate.hs +0/−58
- src/Features.hs +0/−138
- src/Labeler.hs +0/−211
- src/Main.hs +0/−104
- src/NLP/Perceptron/Sequence.hs +297/−0
- src/NLP/Perceptron/Vector.hs +91/−0
- src/NLP/Sequor.hs +245/−0
- src/NLP/Sequor/CoNLL.hs +39/−0
- src/NLP/Sequor/Config.hs +41/−0
- src/NLP/Sequor/FeatureTemplate.hs +58/−0
- src/NLP/Sequor/Features.hs +138/−0
- src/Perceptron/Sequence.hs +0/−269
- src/Perceptron/Vector.hs +0/−91
- src/ghc_rts_opts.c +0/−1
- src/sequor.hs +98/−0
README.rst view
@@ -8,7 +8,18 @@ entity recognizer, with pre-trained models for German and English (see `Named Entity Recognition (SemiNER)`_). +Sequor is especially useful if your dataset has a large label set. In+this case it is likely to run faster and allow you to use much less+RAM than a sequence labeler based on Conditional Random+Fields. Additionally sequor implements options which allow you to+control the size of model and tradeoff speed against accuracy: +- size of the beam+- label dictionary+- feature hashing ++See https://bitbucket.org/gchrupala/sequor/wiki/Options for details.+ Installation ------------ @@ -36,17 +47,20 @@ Usage: sequor command [OPTION...] [ARG...] train: train model train [OPTION...] TEMPLATE-FILE TRAIN-FILE MODEL-FILE - --rate=NUM learning rate- --beam=INT beam size- --iter=INT number of iterations- --min-count=INT minimum feature frequency for label dictionary- --heldout=FILE path to heldout data- --hash use hashing instead of feature dictionary- --hash-sample=INT sample size to estimate number of features when hashing- --hash-max-size=INT maximum size of parameter vector when hashing+ --rate=NUM (0.01) learning rate+ --beam=INT (10) beam size+ --iter=INT (10) number of iterations+ --min-count=INT (100) minimum feature frequency for label dictionary+ --heldout=FILE path to heldout data+ --hash use hashing instead of feature dictionary+ --hash-sample=INT (1000) sample size to estimate number of features when hashing+ --hash-max-size=INT maximum size of parameter vector when hashing :: +See https://bitbucket.org/gchrupala/sequor/wiki/Options for more+details about the training options.+ predict: predict using model predict MODEL-FILE @@ -62,7 +76,7 @@ the data directory. For example:: ./bin/sequor train data/all.features data/train.conll model\- --rate 0.1 --beam 10 --iter 5 --min-count 50 --hash\+ --rate 0.1 --beam 10 --iter 5 --hash\ --heldout data/devel.conll ./bin/sequor predict model < data/test.conll > data/test.labels
lib/Helper/ListZipper.hs view
@@ -32,6 +32,7 @@ fromList [] = LZ [] Nothing [] fromList (x:xs) = LZ [] (Just x) xs +toZippers :: [a] -> [ListZipper a] toZippers xs = let zs = iterate next . fromList $ xs in map snd . zip xs $ zs
sequor.cabal view
@@ -1,5 +1,5 @@ Name: sequor-Version: 0.4.2+Version: 0.7.0 Description: A sequence labeler based on Collins's sequence perceptron. Synopsis: A sequence labeler based on Collins's sequence perceptron. Homepage: http://code.google.com/p/sequor/@@ -25,26 +25,47 @@ seminer/nant.c5.500.topics.classes, seminer/bbn-wsj-22-rate-0.001-beam-10-iter-10-hash-relationfactory-2013.model +Library+ Build-depends: base >= 3 && < 5, + containers >= 0.2, + bytestring >= 0.9.2,+ binary >= 0.5, + mtl >= 1.1,+ vector >= 0.5, + array >= 0.2, + pretty >= 1.0,+ text >= 0.10, + split >= 0.2,+ nlp-scores >= 0.6.0+ Exposed-modules: NLP.Sequor, NLP.Sequor.CoNLL, NLP.Sequor.FeatureTemplate+ hs-source-dirs: src,lib Executable sequor- Main-is: Main.hs+ Main-is: sequor.hs Other-modules: Helper.ListZipper, Helper.Utils, Helper.Text, - Helper.Atom, Helper.Commands, CorpusReader,- FeatureTemplate, Config, Perceptron.Vector,- Perceptron.Sequence, Features, Labeler, Hashable- Build-Depends: base >= 3 && < 5, containers >= 0.2, + Helper.Atom, Helper.Commands, NLP.Sequor.CoNLL,+ NLP.Sequor.FeatureTemplate, NLP.Sequor.Config, NLP.Perceptron.Vector,+ NLP.Perceptron.Sequence, NLP.Sequor.Features, Hashable, NLP.Sequor+ Build-Depends: base >= 3 && < 5, + containers >= 0.2, bytestring >= 0.9.2,- binary >= 0.5, mtl >= 1.1,- vector >= 0.5, array >= 0.2, pretty >= 1.0,- text >= 0.10+ binary >= 0.5, + mtl >= 1.1,+ vector >= 0.5, + array >= 0.2, + pretty >= 1.0,+ text >= 0.10,+ split >= 0.2, + nlp-scores >= 0.6.0 hs-source-dirs: src,lib- ghc-options: -O2 -rtsopts- c-sources: src/ghc_rts_opts.c + ghc-options: -O2 -rtsopts -with-rtsopts=-K128m+ Executable augment Main-is: augment.hs Other-modules: Helper.Utils, Helper.Text Build-Depends: base >= 3 && < 5, containers >= 0.2, text >= 0.10 hs-source-dirs: lib, lib/seminer- ghc-options: -O2 -rtsopts+ ghc-options: -O2 -rtsopts +
− src/Config.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-module Config - ( Config (..), Flags(..) )-where-import Data.Char-import Helper.Atom (AtomTable)-import qualified Data.Binary as B-import Control.Monad (ap)-import FeatureTemplate (Feature)---data Flags = Flags { flagRate :: !Float- , flagBeam :: !Int- , flagIter :: !Int- , flagMinFeatCount :: !Int- , flagHeldout :: Maybe FilePath- , flagHash :: !Bool- , flagHashSample :: !Int- , flagHashMaxSize :: Maybe Int- } --data Config = Config { atomTable :: AtomTable - , featureTemplate :: Feature- , flags :: Flags- , fieldNum :: !Int- }--instance B.Binary Flags where- get = do (f1,f2,f3,f4,f5,f6,f7,f8) <- B.get- return $ Flags f1 f2 f3 f4 f5 f6 f7 f8- put (Flags f1 f2 f3 f4 f5 f6 f7 f8) = B.put (f1,f2,f3,f4,f5,f6,f7,f8)--instance B.Binary Config where- get = let g = B.get- in return Config `ap` g `ap` g `ap` g `ap` g-- put (Config a b c d) =- let p = B.put - in p a >> p b >> p c >> p d
− src/CorpusReader.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module CorpusReader - ( Token- , corpus- , corpusLabeled - , fromWords- )-where-import Helper.ListZipper -import Helper.Utils (splitWith)-import qualified Helper.Text as Text-import Helper.Text (Txt)-import Data.Maybe (isJust)---type Token = [Txt]--corpus :: Int -> Txt -> [[ListZipper Token]]-corpus len =- map toZippers- . map (map $ parseFields . take len)- . splitWith null- . map Text.words- . Text.lines --corpusLabeled ::Txt -> [([ListZipper Token], [Txt])]-corpusLabeled = - map (\xys -> let (xs,ys) = unzip xys in (toZippers xs,ys))- . map (map $ parseFieldsLabeled)- . splitWith null- . map Text.words- . Text.lines- -fromWords :: [Txt] -> [ListZipper Token] -fromWords = toZippers . map (\ w -> [w])--parseFieldsLabeled :: [Txt] -> (Token, Txt)-parseFieldsLabeled ws = (init ws,last ws)--parseFields :: [Txt] -> Token-parseFields ws = ws--
− src/FeatureTemplate.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module FeatureTemplate - ( Feature(..) - , parse- , maybeParse- )-where-import Data.Binary -import Helper.Text(Txt)-import qualified Helper.Text as Text-import qualified Data.List as List-import qualified Data.Char as Char--type Row = Int-type Col = Int--data Feature =- Cell Row Col- | Rect Row Col Row Col- | Row Row- | Index Feature- | MarkNull Feature- | Cat [Feature]- | Cart Feature Feature- | Lower Feature- | Suffix Int Feature- | Prefix Int Feature- | WordShape Feature- deriving (Show,Read)--parse :: Txt -> Feature-parse = maybe (error $ "FeatureTemplate.parse: no parse") id . maybeParse --maybeParse :: Txt -> Maybe Feature-maybeParse s = - case - Text.reads- . Text.unwords- . map uncomment- . Text.lines- $ s- of - (f,r):_ | Text.all Char.isSpace r -> Just f- _ -> Nothing--uncomment :: Txt -> Txt -uncomment s = let splits = map (flip Text.splitAt s) - [1..fromIntegral . Text.length $ s]- in case List.find (("--"`Text.isPrefixOf`) . snd) splits of- Nothing -> s- Just (prefix,_) -> prefix--instance Binary Feature where- put f = put $ Text.show f- get = do- f <- get- return $ Text.read f-
− src/Features.hs
@@ -1,138 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Features - ( features- , maybeFeatures- , inputFeatures- , outputFeatures- , indexFeatures- , eval - )-where--import qualified Helper.Text as Text-import Helper.Text (Txt)-import qualified Helper.ListZipper as LZ-import Helper.ListZipper (ListZipper,at)-import CorpusReader (Token,fromWords)-import qualified Data.Char as Char-import Data.List (group,sort)-import qualified Data.IntSet as IntSet-import qualified Data.IntMap as IntMap-import Helper.Atom (MonadAtoms,AtomTable,from,toAtom,maybeToAtom)-import Data.Maybe (catMaybes,isNothing)-import Control.Monad (liftM2)-import Data.Monoid (mappend)-import Config -import qualified Data.Vector.Unboxed as V-import FeatureTemplate (Feature(..))-import Data.Word (Word,Word64)-import qualified Hashable as H-import Data.Int--toAtom' :: Int -> Txt -> Int-toAtom' size s = fromIntegral ((H.hash s::Word64) `rem` fromIntegral size)--iNDEX_SUFFIX :: Txt-iNDEX_SUFFIX="::index"-iNPUT_PREFIX :: Txt-iNPUT_PREFIX="in:"-oUTPUT_PREFIX :: Txt-oUTPUT_PREFIX="out:"-nULL_MARK :: Txt-nULL_MARK = "<NULL>"---eval :: ListZipper Token -> Feature -> [Maybe Txt]-eval z (Cell r c) = case z `at` r of - [] -> [Nothing]- fs -> [fs `index` c] -eval z (Rect r c r' c') = concat [ eval z (Cell i j) | i <- [r..r'] - , j <- [c..c'] ]-eval z (Row r) = concat [ eval z (Cell r j) - | j <- [0..length (z `at` 0)-1] ]-eval z (MarkNull f) = [ maybe (Just nULL_MARK) Just fi - | fi <- eval z f ]-eval z (Index f) = [ fi+++Just iNDEX_SUFFIX | fi <- eval z f ]-eval z (Cat fs) = concatMap (eval z) fs-eval z (Cart f f') = [ fmap Text.normalize $ fi +++ Just "," +++ fi' - | fi <- eval z f , fi' <- eval z f' ]-eval z (Lower f) = [ fmap (Text.map Char.toLower) fi | fi <- eval z f ]-eval z (Suffix i f) = [ fmap (Text.reverse- . Text.take (fromIntegral i)- . Text.reverse )- $ fi | fi <- eval z f ]-eval z (Prefix i f) = [ fmap (Text.take (fromIntegral i)) $ fi - | fi <- eval z f ]-eval z (WordShape f) = [ fmap (spellingSpec) fi | fi <- eval z f ] --spellingSpec = Text.fromString - . map (\(x:xs) -> x) - . group - . map collapse - . Text.toString--collapse c | Char.isAlpha c && Char.isUpper c = 'X'- | Char.isAlpha c && Char.isLower c = 'x'- | Char.isDigit c = '0'- | c == '-' = '-'- | c == '_' = '_'- | otherwise = '*'--indexFeatures :: AtomTable -> IntSet.IntSet -indexFeatures =- IntMap.keysSet - . IntMap.filter (iNDEX_SUFFIX `Text.isSuffixOf`) - . from --inputFeatures :: Config -> ListZipper Token -> [Txt]-inputFeatures config x =- catMaybes . prefixIndex iNPUT_PREFIX . eval x . featureTemplate $ config--outputFeatures :: [Txt] -> [Txt]-outputFeatures ys = catMaybes . prefixIndex oUTPUT_PREFIX . map Just $- case ys of- (y:y':_) -> [y,y`Text.append`y']- [y] -> [y]- [] -> []--features :: (Functor m, MonadAtoms m) => Maybe (Int,Int) -> Config - -> ListZipper Token - -> m (V.Vector Int)-features bounds config = do - case (flagHash . flags $ config,bounds) of- (True,Just (_,size)) -> - return - . V.fromList - . map (toAtom' size)- . inputFeatures config- (False,Nothing) -> - fmap V.fromList - . mapM toAtom- . inputFeatures config--maybeFeatures :: (Functor m, MonadAtoms m) => Maybe (Int,Int) -> Config - -> ListZipper Token - -> m (V.Vector Int)-maybeFeatures bounds config = do- case (flagHash . flags $ config,bounds) of- (True,Just _) -> features bounds config- (False,Nothing) -> - fmap V.fromList - . fmap catMaybes- . mapM maybeToAtom- . inputFeatures config-prefixIndex :: Txt -> [Maybe Txt] -> [Maybe Txt]-prefixIndex str = zipWith (\i x -> Just str +++ Just (Text.show i) - +++ Just "=" - +++ x ) - [1..]--(+++) = liftM2 (\s t -> Text.concat [s,t])--index [] _ = Nothing-index (x:_) 0 = Just x-index (_:xs) i = index xs (i-1)---sent = LZ.fromList [["I","pro"],["like","v"],["Ike","pn"]] :: ListZipper Token
− src/Labeler.hs
@@ -1,211 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Labeler - ( ModelData(..)- , Config(..)- , train- , predict- )- -where--import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import Data.List (foldl',tails)-import Data.Maybe (fromMaybe)-import Helper.ListZipper-import qualified Perceptron.Sequence as P-import Perceptron.Sequence (Options(..))-import CorpusReader (Token)-import Helper.Utils (splitWith,uniq)-import Text.Printf-import Helper.Atom-import Control.Monad.RWS-import Features (inputFeatures,features,maybeFeatures,outputFeatures- ,indexFeatures)-import qualified Data.Array as A-import qualified Data.Vector.Unboxed as V-import qualified Data.Binary as Binary-import qualified Helper.Text as Text-import Helper.Text(Txt)-import Data.Char-import Data.Maybe (catMaybes)-import Config ---data ModelData = ModelData { model :: P.Model- , config :: Config- } -instance Binary.Binary ModelData where- get = return ModelData `ap` Binary.get `ap` Binary.get- put (ModelData a b) = Binary.put a >> Binary.put b ------- Main exported functions -predict :: ModelData -> [[ListZipper Token]] -> [[Txt]]-predict m testdat = - let bounds = oFeatBounds . P.options . model $ m- in fst . flip runAtoms (atomTable . config $ m) $- do flip mapM testdat $ \x -> - do x' <- mapM (maybeFeatures bounds (config m)) $ x- predict' (P.decode (model m)) $ x'--train :: Config - -> [([ListZipper Token],[Txt])]- -> [([ListZipper Token],[Txt])]- -> ModelData-train conf traindat heldout = - let ((m,_predicted),_atoms) = - runAtoms (run conf - traindat - heldout) - $ empty- in m---- Implementation-type F = Int-type Tag = Int-tagDictionary :: IntSet.IntSet - -> Int - -> [([V.Vector Int], [F])] - -> IntMap.IntMap [Tag]-tagDictionary indexFeatureSet wmin trainset = - let tags = concat . map snd $ trainset- ws = catMaybes - . map (V.find (`IntSet.member` indexFeatureSet))- . concat - . map fst - $ trainset- count_ws = IntMap.fromListWith (+) [ (w,1) | w <- ws ]- dict = IntMap.map Set.toList- . IntMap.fromListWith Set.union - $ [ (w,Set.singleton t) | (w,t) <- zip ws tags - , count_ws IntMap.! w >= wmin]- in dict == dict `seq` dict--pruneLabels :: Int -> [(x,[Txt])] -> [(x,[Txt])]-pruneLabels lim xys =- let freq = Map.fromListWith (+)- . map (\y -> (y,1))- . concat- . map snd- $ xys- undet = "UNDETERMINED"- in [ (x,[ if freq Map.! yi < lim then undet else yi | yi <- y ]) - | (x,y) <- xys ]--run :: (Functor m, MonadAtoms m) =>- Config- -> [([ListZipper Token], [Txt])]- -> [([ListZipper Token], [Txt])]- -> m (ModelData, [[Txt]])-run conf trainset_in testset_in = do- let --trainset_in = pruneLabels (minLabelFreq conf) trainset_in_full- ys = uniq . concat . map snd $ trainset_in :: [Txt]- ys' <- mapM toAtom ys- outm <- mkOutputFeatureAtoms . map snd $ trainset_in - let size = outputFeatureCount outm + - maybe (estimateFeatureCount conf . map fst $ trainset_in)- id- (flagHashMaxSize . flags $ conf)- bounds = if flagHash . flags $ conf - then Just (0,size)- else Nothing- trainset <- mapM (mkfs $ features bounds conf) trainset_in- testset <- mapM (mkfs $ maybeFeatures bounds conf) testset_in - tab <- table- let indexFeatureSet = indexFeatures tab- conf' = conf {atomTable = tab }- opts = Options { oYMap = outm- , oIndexSet = indexFeatureSet- , oYDict = tagDictionary indexFeatureSet - (flagMinFeatCount . flags $ conf') trainset- , oYs = ys'- , oBeam = flagBeam . flags $ conf- , oRate = flagRate . flags $ conf- , oEpochs = flagIter . flags $ conf- , oFeatBounds = bounds- }- m = P.train opts testset formatEval trainset- ps <- mapM (predict' (P.decode m . fst)) testset- return $ (ModelData { model = m , config = conf' }- ,ps)--predict' :: (MonadAtoms m) =>- (t -> [Int]) -> t -> m [Txt]-predict' dec x = do- let xr = dec x- xr'<- mapM fromAtom xr- return xr'--mkOutputFeatureAtoms :: (MonadAtoms m) => [[Txt]] -> m P.YMap-mkOutputFeatureAtoms yss = do- let unigrams = map return . uniq . concat $ yss- bigrams = uniq $ concat [ filter ((==2) . length) - . map (take 2) - . tails - $ ys | ys <- yss ]- unigramis <- mapM (mapM toAtom) unigrams- bigramis <- mapM (mapM toAtom) bigrams- let ys = map head unigramis- (lo,hi) = (minimum ys,maximum ys)- unigramfs <- mapM (mapM toAtom) . map outputFeatures $ unigrams- bigramfs <- mapM (mapM toAtom) . map outputFeatures $ bigrams- zerofs <- mapM toAtom . outputFeatures $ []- let ymap1 = A.accumArray (V.++) V.empty (lo,hi) - . zip (map head unigramis) - . map V.fromList- $ unigramfs- ymap2 = A.accumArray (V.++) V.empty ((lo,lo),(hi,hi)) - . zip (map (\ [y1,y2] -> (y1,y2)) bigramis)- . map V.fromList- $ bigramfs - return $ (V.fromList zerofs, ymap1, ymap2)--outputFeatureCount :: P.YMap -> Int-outputFeatureCount (zero,uni,bi) = - maximum (V.toList zero - ++ (concatMap V.toList . A.elems $ uni)- ++ (concatMap V.toList . A.elems $ bi ))- -mkfs :: (MonadAtoms m) => - (ListZipper Token -> m (V.Vector F))- -> ([ListZipper Token], [Txt]) - -> m ([V.Vector F], [Tag])-mkfs f (x,y) = do- fs <- mapM f x- fs == fs `seq` return ()- y' <- mapM toAtom y- y' == y' `seq` return ()- return $ (fs,y')--estimateFeatureCount :: Config -> [[ListZipper Token]] -> Int-estimateFeatureCount conf xs = - let len = length xs- size = min len . flagHashSample . flags $ conf- factor = length xs `div` size- tokno = (factor *) - . length - . uniq- . concatMap (concatMap (inputFeatures conf))- . take size- $ xs- in tokno--formatEval :: P.Eval -formatEval 0 _ _ = printf "%10s %10s %10s" ("Iter"::String) - ("Train"::String)- ("Heldout"::String)-formatEval i ss heldout = printf "%10d %10.4f %10.4f" i (eval ss) (eval heldout)- --eval :: Eq a => [([a],[a])] -> Double-eval ys = - let corr = foldl' (+) 0 - . concat- $ [ [ 1 | (y,y') <- ys , (yi,yi') <- zip y y' - , yi == yi' ] ]- in corr / fromIntegral (length . concatMap fst $ ys)
− src/Main.hs
@@ -1,104 +0,0 @@-module Main (main)-where-import qualified Labeler as L -import CorpusReader (corpus,corpusLabeled)-import qualified Helper.Text as Text-import qualified Helper.ListZipper as Z-import qualified Data.Binary as Binary-import qualified Data.ByteString.Lazy as ByteString-import System.Environment (getArgs)-import System.IO (hPutStrLn,stderr)-import FeatureTemplate (parse)-import Helper.Commands ( CommandSpec (..),defaultMain , usage - , Command- , OptDescr(Option), ArgDescr(ReqArg,NoArg))-import Config(Flags(..))---commands :: [(String, CommandSpec Flags)] -commands = - [ ("train", CommandSpec train "train model"- [ Option [] ["rate"] - (ReqArg (\a o -> o { flagRate = read a }) "NUM")- "learning rate"- , Option [] ["beam"] - (ReqArg (\a o -> o { flagBeam = read a }) "INT")- "beam size"- , Option [] ["iter"] - (ReqArg (\a o -> o { flagIter = read a }) "INT")- "number of iterations"- , Option [] ["min-count"] - (ReqArg (\a o -> o { flagMinFeatCount = read a }) "INT")- "minimum feature frequency for label dictionary"- , Option [] ["heldout"]- (ReqArg (\a o -> o { flagHeldout = Just a }) "FILE")- "path to heldout data"- , Option [] ["hash"] - (NoArg (\o -> o { flagHash = True }))- "use hashing instead of feature dictionary"- , Option [] ["hash-sample"] - (ReqArg (\a o -> o { flagHashSample = read a }) "INT")- "sample size to estimate number of features when hashing"- , Option [] ["hash-max-size"] - (ReqArg (\a o -> o { flagHashMaxSize - = Just $ read a }) "INT")- "maximum size of parameter vector when hashing" ]- ["TEMPLATE-FILE","TRAIN-FILE","MODEL-FILE"])- , ("predict", CommandSpec predict "predict using model" []- ["MODEL-FILE"])- , ("version", CommandSpec version "print version" [] [])- , ("help" , CommandSpec help "print usage information" [] [])- ]- -defaultFlags = Flags { flagRate = 0.01- , flagBeam = 10- , flagIter = 10- , flagMinFeatCount = 100- , flagHeldout = Nothing- , flagHash = False- , flagHashSample = 1000- , flagHashMaxSize = Nothing- } --train :: Command Flags-train flags [templatef,trainf,outf] = do- template <- parse `fmap` Text.readFile templatef- traindat <- fmap corpusLabeled $ Text.readFile trainf- testdat <- case flagHeldout flags of- Nothing -> return []- Just testf -> fmap corpusLabeled $ Text.readFile testf- let len = case fmap length . Z.focus . (\(x:_) -> x) . fst . (\(x:_) -> x) - $ traindat of- Just i -> i- conf = L.Config { L.featureTemplate = template - , L.atomTable = error - "main:Config.atomTable undefined" - , L.flags = flags- , L.fieldNum = len- }- ByteString.writeFile outf - . Binary.encode - . L.train conf traindat - $ testdat--predict :: Command Flags-predict flags [modelf] = do- m <- fmap Binary.decode (ByteString.readFile modelf)- testdat <- fmap (corpus (L.fieldNum . L.config $ m)) $ Text.getContents- Text.putStr - . Text.unlines - . map Text.unlines - . L.predict m- $ testdat--version :: Command Flags -version _ _ = putStrLn "sequor-0.2.2"--help :: Command Flags-help _ _ = usage commands msg []--main :: IO () -main = defaultMain defaultFlags commands msg--msg = "Usage: sequor command [OPTION...] [ARG...]"-
+ src/NLP/Perceptron/Sequence.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE NoMonomorphismRestriction + , BangPatterns+ , FlexibleInstances+ #-}+module NLP.Perceptron.Sequence+ (+ Model(..)+ , Trace+ , Options(..)+ , YMap+ , train+ , decode+ )+where++import qualified Data.Array.Unsafe as AU+import Data.Array.ST+import Data.Array.Unboxed+import qualified Data.Array as A+import qualified Data.Vector.Unboxed as V+import Control.Monad.ST +import qualified Control.Monad.ST.Lazy as LST+import qualified Control.Monad.ST.Unsafe as ST.Unsafe+import Control.Monad.Writer +import Data.STRef+import Control.Monad+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import NLP.Perceptron.Vector+import System.IO+import Debug.Trace+--import NLP.Perceptron.Config +import Data.List (inits,foldl',sortBy)+import Data.Ord (comparing)+import Helper.ListZipper +import qualified Data.Binary as Binary+import Helper.Utils (uniq)+import qualified NLP.Scores as Scores+import Text.Printf++data Model = Model { options :: Options + , weights :: UArray I Float }+type X = [Xi]+type Y = [Yi]+type Xi = V.Vector Xii+type Xii = Int+type Yi = Int+type Dot = Local -> Float++data Options = Options { oYMap :: YMap+ , oIndexSet :: IntSet.IntSet+ , oYDict :: IntMap.IntMap [Yi]+ , oYs :: [Yi]+ , oBeam :: !Int + , oRate :: !Float+ , oEpochs :: !Int + , oFeatBounds :: Maybe (Int,Int)+ , oStopWinSize :: !Int+ , oStopThreshold :: !Double+ } deriving Eq++type YMap = (Xi,A.Array Yi Xi,A.Array (Yi,Yi) Xi)++instance Binary.Binary (V.Vector Int) where+ put v = Binary.put $ V.toList v+ get = V.fromList `fmap` Binary.get+ +instance Binary.Binary Model where+ put m = do + Binary.put (options m)+ -- Binary.put (weights m)+ let (lo,hi) = bounds . weights $ m+ xs = filter (\(_,e) -> e /= 0.0) . assocs . weights $ m+ Binary.put (lo,hi)+ Binary.put xs++ get = {-# SCC "get1" #-} do + os <- Binary.get + os == os `seq` return ()+ ws <- do+ (lo,hi) <- Binary.get+ xs <- Binary.get+ xs == xs `seq` return ()+ return $ accumArray (+) 0 (lo,hi) $ xs+ ws == ws `seq` return ()+ return $ Model os ws++instance Binary.Binary Options where+ put (Options a b c d e f g h i j) = Binary.put a >> Binary.put b >> Binary.put c + >> Binary.put d >> Binary.put e >> Binary.put f+ >> Binary.put g >> Binary.put h >> Binary.put i >> Binary.put j+ get = {-# SCC "get2" #-} do+ a <- Binary.get+ a == a `seq` return ()+ b <- Binary.get+ b == b `seq` return ()+ c <- Binary.get + c == c `seq` return ()+ d <- Binary.get + d == d `seq` return ()+ e <- Binary.get+ e == e `seq` return ()+ f <- Binary.get+ f == f `seq` return ()+ g <- Binary.get+ g == g `seq` return ()+ h <- Binary.get+ h == h `seq` return ()+ i <- Binary.get+ i == i `seq` return ()+ j <- Binary.get+ j == j `seq` return ()+ return $ Options a b c d e f g h i j++yDictFind :: Options -> Xi -> [Yi]+yDictFind opts fs = + let mk = V.find (`IntSet.member` oIndexSet opts) $ fs+ def = oYs opts+ in case mk of+ Just k -> IntMap.findWithDefault def k . oYDict $ opts+ Nothing -> def++-- | DECODING +decode :: Model -> X -> Y+decode m = fst . decode' (options m) (weights m `dot`) ++data Cell = Cell { cScore :: !Float+ , cPhi :: Global+ , cPath :: Y+ , cStep :: ListZipper Xi } deriving (Show,Eq)++decode' :: Options -> Dot -> X -> (Y,Global)+decode' opts w x = + bestPath opts w [Cell { cScore = 0 + , cPhi = Map.empty+ , cPath = []+ , cStep = fromList x } ]+++phi :: Options -> X -> Y -> Global+phi opts x y = foldl' f Map.empty . zip x . map reverse . tail . inits $ y+ where f z (xi,ys) = z `plus` toSV (features (oYMap opts) xi ys)++{-# INLINE features #-} +features :: YMap -> Xi -> [Yi] -> Local+features (!zero,uni,bi) xi (y:ys) = + case ys of+ [] -> (Local y $ zero V.++ xi)+ [y1] -> (Local y $ uni A.! y1 V.++ xi)+ (y1 : y2 : _) -> let r = bi A.! (y1,y2) + in if V.null r + then (Local y $ uni A.! y1 V.++ xi)+ else (Local y $ r V.++ xi)++beamSearch :: Options+ -> Dot+ -> [Cell] + -> [Cell]+beamSearch opts w cs = + let f cs = if any (atEnd . cStep) cs then cs + else + let cs' = [ let fs = features (oYMap opts) xi (y':ys)+ in Cell { cScore = + s + w fs + , cPhi = ph `plus` (toSV fs)+ , cPath = (y':ys)+ , cStep = next x } + | Cell { cScore = s + , cPhi = ph + , cPath = ys + , cStep = x } <- cs + , let Just xi = focus x+ , y' <- yDictFind opts xi+ ]+ in f . take (oBeam opts) + . sortBy (flip $ comparing cScore) + $ cs'+ in f cs ++bestPath :: Options+ -> Dot+ -> [Cell]+ -> (Y, Global)+bestPath opts w xs = + let xs' = beamSearch opts w xs+ first = (\(x:_) -> x) xs'+ in ( reverse . cPath $ first+ , cPhi first )++-- | TRAINING++iter :: Options + -> Int+ -> [(X,Y)]+ -> (STRef s Int, WeightsST s, WeightsST s)+ -> ST s ()+iter opts _ ss (c,params,params_a) = do+ for_ ss $ \ (x,y) -> do+ params' <- AU.unsafeFreeze params+ let (y',phi_xy') = decode' opts (params'`dot`) x+ when (y' /= y) $ do + let phi_xy = phi opts x y + update = (phi_xy `minus` phi_xy') `scale` oRate opts+ params `plus_` update+ c' <- readSTRef c+ params_a `plus_` (update `scale` fromIntegral c')+ modifySTRef c (+1)++type Trace = [(Double, Double, Double)]+ +train :: Options -> [(X, Y)] -> [(X,Y)] -> (Model, Trace)+train opts heldout ss = LST.runST (runWriterT (run opts heldout ss))+ +run :: Options -> [(X, Y)] -> [(X,Y)] -> WriterT Trace (LST.ST s) Model+run opts heldout ss = do+ let bs = computeBounds opts ss+ --trace ("Param vector bounds: " ++ show bs) () `seq` return ()+ params <- st $ newArray bs 0+ params_a <- st $ newArray bs 0+ c <- st $ newSTRef 1+ erref <- st $ newSTRef []+ let loop i = do+ st $ iter opts i ss (c, params, params_a)+ c' <- st $ readSTRef c+ params' <- st $ AU.unsafeFreeze params+ params_a' <- st $ AU.unsafeFreeze params_a+ let w = (fromIntegral c', params', params_a')+ pred xys = [ fst . decode' opts (w `dot'`) $ x + | (x,_) <- xys ]+ err_train = Scores.errorRate (concatMap snd ss) (concat $ pred ss) + err_dev = Scores.errorRate (concatMap snd heldout) (concat $ pred heldout)+ errs <- st $ readSTRef erref + let errs' = (err_train, err_dev):errs+ st $ writeSTRef erref errs' + let ch = change (oStopWinSize opts) errs'+ tell [(err_train, err_dev, ch)]+ when (continue opts i ch) $ loop (i+1)+ loop 1 + st $ finalParams (c, params, params_a)+ arr <- st $ AU.unsafeFreeze params+ return $! Model { options = opts , weights = arr }+ +st :: Monoid w => ST s a -> WriterT w (LST.ST s) a+st = lift . LST.strictToLazyST++change :: Int -> [(Double, Double)] -> Double+change winsize errs =+ let mi = minimum . take winsize . map snd $ errs+ ma = maximum . take winsize . map snd $ errs+ in (ma - mi)/ma + +continue :: Options -> Int -> Double -> Bool+continue opts i n | i >= oEpochs opts = False+ | i < winsize = True + | isNaN n = True + | True = n > threshold + where threshold = oStopThreshold opts+ winsize = oStopWinSize opts+ +finalParams :: (STRef s Int, WeightsST s, WeightsST s) + -> ST s ()+finalParams (c,params,params_a) = do+ (l,u) <- getBounds params+ c' <- fmap fromIntegral (readSTRef c)+ for_ (range (l,u)) $ \i -> do+ e <- readArray params i+ e_a <- readArray params_a i+ writeArray params i (e - (e_a * (1/c')))++computeBounds :: Options -> [(X,Y)] -> (I,I)+computeBounds opts xys = + let ((yl,xl),(yh,xh)) = foldl' f ((maxBound,minimum xis)+ ,(minBound,maximum xis)) + . (\(xs,ys) -> zip (concat xs) (concat ys))+ . unzip+ $ xys+ in case oFeatBounds opts of+ Just (xl',xh') -> (I yl xl',I yh xh')+ Nothing -> (I yl xl,I yh xh)+ where f ((!miny,!minx),(!maxy,!maxx)) (xs,!y) =+ ((min miny y,V.minimum $ minx`V.cons`xs)+ ,(max maxy y,V.maximum $ maxx`V.cons`xs))+ xis = let (zero,uni,bi) = oYMap opts+ in uniq+ . concatMap V.toList+ $+ [zero]+ +++ (filter (not . V.null)+ . A.elems+ $ bi)+ +++ (filter (not . V.null) + . A.elems + $ uni)+
+ src/NLP/Perceptron/Vector.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleContexts , BangPatterns #-}+module NLP.Perceptron.Vector + ( I(..)+ , Global+ , Local(..)+ , Weights+ , WeightsST+ , toSV+ , for_+ , plus_+ , minus_+ , plus+ , minus+ , scale+ , dot + , dot'+ )+where++import Data.Array.ST+import Data.Array.Unboxed+import Control.Monad.ST+import Data.STRef+import Control.Monad+import qualified Data.Map as Map+import Data.List (foldl',sort)+import qualified Data.Vector.Unboxed as V+import Data.Binary++data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Int deriving (Eq,Ord,Ix,Show)+instance Binary I where + put (I i j) = put (i,j)+ get = uncurry I `fmap` get++type Global = Map.Map I Float+data Local = Local {-# UNPACK #-} !Int !(V.Vector Int)+type WeightsST s = STUArray s I Float+type Weights = UArray I Float++++for_ xs f = mapM_ f xs++plus_ :: WeightsST s -> Global -> ST s ()+plus_ w v = do+ for_ (Map.toList v) $ \(i,vi) -> do+ wi <- readArray w i + writeArray w i (wi + vi)+minus_ w v = plus_ w (v `scale` (-1))++scale :: Global -> Float -> Global+scale v n = Map.map (*n) v++plus :: Global -> Global -> Global+plus u v = Map.unionWith (+) u v+minus :: Global -> Global -> Global+minus u v = u `plus` (v `scale` (-1))+++dot :: Weights -> Local -> Float+{-# INLINE dot #-}+dot w (Local !y x) = V.foldl' (\ !z !i -> z + w ! I y i) 0 x+-- For some reason explicit loop doesn't help here+-- dot !w (Local y x) = go 0 0+-- where !len = V.length x+-- go !z !j | j == len = z+-- go !z !j = go (z + w ! I y (x V.! j)) (j+1)+++dot' :: (Float,Weights,Weights) -> Local -> Float+{-# INLINE dot' #-}+-- dot' (!c,!params,!params_a) (Local y x) = V.foldl' (\ !z !j -> +-- let i = I y j+-- e = params ! i +-- e_a = params_a ! i+-- in z + (e - (e_a / c)))+-- 0+-- x+++dot' (!c,!params,!params_a) (Local y x) = go 0 0+ where !len = V.length x+ go !z !j | j == len = z+ go !z !j = + let i = I y (x V.! j)+ e = params ! i+ e_a = params_a ! i+ in go (z + (e - (e_a / c))) (j+1)++toSV :: (V.Unbox Int) => Local -> Global+toSV (Local y v) = Map.fromList [ (I y i,1) | i <- V.toList v ]
+ src/NLP/Sequor.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedStrings #-}+module NLP.Sequor + ( ModelData+ , P.Trace+ , Template.Feature+ , Config+ , Token+ , Label+ , Sentence+ , train+ , predict+ , parseTemplate+ , defaultFlags+ )+ +where++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import Data.List (foldl',tails)+import Data.Maybe (fromMaybe)+import Helper.ListZipper+import qualified NLP.Perceptron.Sequence as P+import NLP.Perceptron.Sequence (Options(..))+import NLP.Sequor.CoNLL+import Helper.Utils (splitWith,uniq)+import Helper.Atom+import Control.Monad.RWS+import NLP.Sequor.Features (inputFeatures,features,maybeFeatures,outputFeatures,indexFeatures)+import qualified NLP.Sequor.FeatureTemplate as Template+import qualified Data.Array as A+import qualified Data.Vector.Unboxed as V+import qualified Data.Binary as Binary+import qualified Helper.Text as Text+import Helper.Text(Txt)+import qualified Data.Text.Lazy as Text+import Data.Char+import Data.Maybe (catMaybes)+import NLP.Sequor.Config +import Text.Printf+import Debug.Trace++data ModelData = ModelData { model :: P.Model -- ^ Sequence perceptron model+ , config :: Config -- ^ Model configuration options+ } + +instance Binary.Binary ModelData where+ get = return ModelData `ap` Binary.get `ap` Binary.get+ put (ModelData a b) = Binary.put a >> Binary.put b +++ +-- | @predict model sentence@ returns the best label sequence for+-- sentence. A sentence is a sequence of 'Token's.+predict :: ModelData -> [[Token]] -> [[Label]]+predict m testdat = + let bounds = oFeatBounds . P.options . model $ m+ in fst . flip runAtoms (maybe (error "NLP.Sequor.predict:Nothing") id . atomTable . config $ m) + $ do flip mapM (map (toZippers . map (take (fieldNumber m))) testdat) $ \x -> + do x' <- mapM (maybeFeatures bounds (config m)) $ x+ predict' (P.decode (model m)) $ x'++-- | @train flags template training development@ trains a model on training+-- sentences using give flags and feature template and returns the model and a+-- for each iteration the error rate on training and development sentences.+train :: Flags + -> Template.Feature+ -> [(Sentence, [Label])]+ -> [(Sentence, [Label])]+ -> (ModelData, P.Trace)+train fs template traindat heldout = + let len = length . (\(x:_) -> x) . fst . (\(x:_) -> x) $ traindat + conf = Config { featureTemplate = template+ , atomTable = Nothing+ , flags = fs + , fieldNum = len }+ ((m,_predicted, info),_atoms) = + runAtoms (run conf + (zippify traindat)+ (zippify heldout))+ $ empty+ in (m, info)++-- | @parseTemplete s@ parses feature template in s and returns the+-- result.+parseTemplate :: Text.Text -> Template.Feature+parseTemplate = Template.parse++defaultFlags :: Flags+defaultFlags = Flags { flagRate = 0.01+ , flagBeam = 10+ , flagIter = 10+ , flagMinFeatCount = 100+ , flagHeldout = Nothing+ , flagHash = False+ , flagHashSample = 1000+ , flagHashMaxSize = Nothing+ , flagStopWinSize = 5+ , flagStopThreshold = 0.05+ } ++-- Implementation++fieldNumber :: ModelData -> Int+fieldNumber = fieldNum . config+++type F = Int+type Tag = Int++zippify :: [([Token], [Txt])] -> [([ListZipper Token], [Txt])]+zippify = map (\ (x, y) -> (toZippers x, y))+++tagDictionary :: IntSet.IntSet + -> Int + -> [([V.Vector Int], [F])] + -> IntMap.IntMap [Tag]+tagDictionary indexFeatureSet wmin trainset = + let tags = concat . map snd $ trainset+ ws = catMaybes + . map (V.find (`IntSet.member` indexFeatureSet))+ . concat + . map fst + $ trainset+ count_ws = IntMap.fromListWith (+) [ (w,1) | w <- ws ]+ dict = IntMap.map Set.toList+ . IntMap.fromListWith Set.union + $ [ (w,Set.singleton t) | (w,t) <- zip ws tags + , count_ws IntMap.! w >= wmin]+ in dict == dict `seq` dict++pruneLabels :: Int -> [(x,[Txt])] -> [(x,[Txt])]+pruneLabels lim xys =+ let freq = Map.fromListWith (+)+ . map (\y -> (y,1))+ . concat+ . map snd+ $ xys+ undet = "UNDETERMINED"+ in [ (x,[ if freq Map.! yi < lim then undet else yi | yi <- y ]) + | (x,y) <- xys ]++run :: (Functor m, MonadAtoms m) =>+ Config+ -> [([ListZipper Token], [Txt])]+ -> [([ListZipper Token], [Txt])]+ -> m (ModelData, [[Txt]], P.Trace)+run conf trainset_in testset_in = do+ let --trainset_in = pruneLabels (minLabelFreq conf) trainset_in_full+ ys = uniq . concat . map snd $ trainset_in :: [Txt]+ ys' <- mapM toAtom ys+ outm <- mkOutputFeatureAtoms . map snd $ trainset_in + let size = outputFeatureCount outm + + maybe (estimateFeatureCount conf . map fst $ trainset_in)+ id+ (flagHashMaxSize . flags $ conf)+ bounds = if flagHash . flags $ conf + then Just (0,size)+ else Nothing+ trainset <- mapM (mkfs $ features bounds conf) trainset_in+ testset <- mapM (mkfs $ maybeFeatures bounds conf) testset_in + tab <- table+ let indexFeatureSet = indexFeatures tab+ conf' = conf {atomTable = Just tab }+ opts = Options { oYMap = outm+ , oIndexSet = indexFeatureSet+ , oYDict = tagDictionary indexFeatureSet + (flagMinFeatCount . flags $ conf') trainset+ , oYs = ys'+ , oBeam = flagBeam . flags $ conf+ , oRate = flagRate . flags $ conf+ , oEpochs = flagIter . flags $ conf+ , oFeatBounds = bounds+ , oStopWinSize = flagStopWinSize . flags $ conf+ , oStopThreshold = flagStopThreshold . flags $ conf+ }+ + (m, info) = P.train opts testset trainset+ ps <- mapM (predict' (P.decode m . fst)) testset+ return (ModelData { model = m , config = conf' } , ps, info)+++predict' :: (MonadAtoms m) =>+ (t -> [Int]) -> t -> m [Txt]+predict' dec x = do+ let xr = dec x+ xr'<- mapM fromAtom xr+ return xr'++mkOutputFeatureAtoms :: (MonadAtoms m) => [[Txt]] -> m P.YMap+mkOutputFeatureAtoms yss = do+ let unigrams = map return . uniq . concat $ yss+ bigrams = uniq $ concat [ filter ((==2) . length) + . map (take 2) + . tails + $ ys | ys <- yss ]+ unigramis <- mapM (mapM toAtom) unigrams+ bigramis <- mapM (mapM toAtom) bigrams+ let ys = map head unigramis+ (lo,hi) = (minimum ys,maximum ys)+ unigramfs <- mapM (mapM toAtom) . map outputFeatures $ unigrams+ bigramfs <- mapM (mapM toAtom) . map outputFeatures $ bigrams+ zerofs <- mapM toAtom . outputFeatures $ []+ let ymap1 = A.accumArray (V.++) V.empty (lo,hi) + . zip (map head unigramis) + . map V.fromList+ $ unigramfs+ ymap2 = A.accumArray (V.++) V.empty ((lo,lo),(hi,hi)) + . zip (map (\ [y1,y2] -> (y1,y2)) bigramis)+ . map V.fromList+ $ bigramfs + return $ (V.fromList zerofs, ymap1, ymap2)++outputFeatureCount :: P.YMap -> Int+outputFeatureCount (zero,uni,bi) = + maximum (V.toList zero + ++ (concatMap V.toList . A.elems $ uni)+ ++ (concatMap V.toList . A.elems $ bi ))+ +mkfs :: (MonadAtoms m) => + (ListZipper Token -> m (V.Vector F))+ -> ([ListZipper Token], [Txt]) + -> m ([V.Vector F], [Tag])+mkfs f (x,y) = do+ fs <- mapM f x+ fs == fs `seq` return ()+ y' <- mapM toAtom y+ y' == y' `seq` return ()+ return $ (fs,y')++estimateFeatureCount :: Config -> [[ListZipper Token]] -> Int+estimateFeatureCount conf xs = + let len = length xs+ size = min len . flagHashSample . flags $ conf+ factor = length xs `div` size+ tokno = (factor *) + . length + . uniq+ . concatMap (concatMap (inputFeatures conf))+ . take size+ $ xs+ in tokno
+ src/NLP/Sequor/CoNLL.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+module NLP.Sequor.CoNLL+ ( Token+ , Field+ , Label+ , Sentence+ , parse+ , toLabeled + )+where++import qualified Data.Text.Lazy as Text +import Data.List.Split ++-- | @Token@ is a representation of a word, which consists of a number of fields.+type Token = [Text.Text]++-- | @Field@ is a part of a word token, such as word form, lemma or POS tag. +type Field = Text.Text++-- | @Sentence@ is a sequence of tokens.+type Sentence = [Token]++-- | @Label@ is a label associated to a token.+type Label = Text.Text++ +-- | @parse text@ returns a lazy list of sentences.+parse :: Text.Text -> [Sentence]+parse = + splitWhen null+ . map Text.words+ . Text.lines ++-- | @toLabeled s@ converts the last field of each token in @s@ to a+-- label and returns a pair whose first element is the sentence and+-- the second the corresponding sequence of labels.+toLabeled :: Sentence -> (Sentence, [Label])+toLabeled = unzip . map (\ xs -> (init xs, last xs))
+ src/NLP/Sequor/Config.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module NLP.Sequor.Config + ( Config (..), Flags(..) )+where+import Data.Char+import Helper.Atom (AtomTable)+import qualified Data.Binary as B+import Control.Monad (ap)+import NLP.Sequor.FeatureTemplate (Feature)+++data Flags = Flags { flagRate :: !Float+ , flagBeam :: !Int+ , flagIter :: !Int+ , flagMinFeatCount :: !Int+ , flagHeldout :: Maybe FilePath+ , flagHash :: !Bool+ , flagHashSample :: !Int+ , flagHashMaxSize :: Maybe Int+ , flagStopWinSize :: !Int+ , flagStopThreshold :: !Double+ } ++data Config = Config { atomTable :: Maybe AtomTable + , featureTemplate :: Feature+ , flags :: Flags+ , fieldNum :: !Int+ }++instance B.Binary Flags where+ get = do (f1,f2,f3,f4,f5,f6,f7,f8,f9,f10) <- B.get+ return $ Flags f1 f2 f3 f4 f5 f6 f7 f8 f9 f10+ put (Flags f1 f2 f3 f4 f5 f6 f7 f8 f9 f10) = B.put (f1,f2,f3,f4,f5,f6,f7,f8,f9,f10)++instance B.Binary Config where+ get = let g = B.get+ in return Config `ap` g `ap` g `ap` g `ap` g++ put (Config a b c d) =+ let p = B.put + in p a >> p b >> p c >> p d
+ src/NLP/Sequor/FeatureTemplate.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+module NLP.Sequor.FeatureTemplate + ( Feature(..) + , parse+ , maybeParse+ )+where+import Data.Binary +import Helper.Text(Txt)+import qualified Helper.Text as Text+import qualified Data.List as List+import qualified Data.Char as Char++type Row = Int+type Col = Int++data Feature =+ Cell Row Col+ | Rect Row Col Row Col+ | Row Row+ | Index Feature+ | MarkNull Feature+ | Cat [Feature]+ | Cart Feature Feature+ | Lower Feature+ | Suffix Int Feature+ | Prefix Int Feature+ | WordShape Feature+ deriving (Show,Read)++parse :: Txt -> Feature+parse = maybe (error $ "FeatureTemplate.parse: no parse") id . maybeParse ++maybeParse :: Txt -> Maybe Feature+maybeParse s = + case + Text.reads+ . Text.unwords+ . map uncomment+ . Text.lines+ $ s+ of + (f,r):_ | Text.all Char.isSpace r -> Just f+ _ -> Nothing++uncomment :: Txt -> Txt +uncomment s = let splits = map (flip Text.splitAt s) + [1..fromIntegral . Text.length $ s]+ in case List.find (("--"`Text.isPrefixOf`) . snd) splits of+ Nothing -> s+ Just (prefix,_) -> prefix++instance Binary Feature where+ put f = put $ Text.show f+ get = do+ f <- get+ return $ Text.read f+
+ src/NLP/Sequor/Features.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}++module NLP.Sequor.Features + ( features+ , maybeFeatures+ , inputFeatures+ , outputFeatures+ , indexFeatures+ , eval + )+where++import qualified Helper.Text as Text+import Helper.Text (Txt)+import qualified Helper.ListZipper as LZ+import Helper.ListZipper (ListZipper,at)+import qualified Data.Char as Char+import Data.List (group,sort)+import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap+import Helper.Atom (MonadAtoms,AtomTable,from,toAtom,maybeToAtom)+import Data.Maybe (catMaybes,isNothing)+import Control.Monad (liftM2)+import Data.Monoid (mappend)+import NLP.Sequor.Config +import qualified Data.Vector.Unboxed as V+import NLP.Sequor.FeatureTemplate (Feature(..))+import Data.Word (Word,Word64)+import qualified Hashable as H+import Data.Int+import NLP.Sequor.CoNLL++toAtom' :: Int -> Txt -> Int+toAtom' size s = fromIntegral ((H.hash s::Word64) `rem` fromIntegral size)++iNDEX_SUFFIX :: Txt+iNDEX_SUFFIX="::index"+iNPUT_PREFIX :: Txt+iNPUT_PREFIX="in:"+oUTPUT_PREFIX :: Txt+oUTPUT_PREFIX="out:"+nULL_MARK :: Txt+nULL_MARK = "<NULL>"+++eval :: ListZipper Token -> Feature -> [Maybe Txt]+eval z (Cell r c) = case z `at` r of + [] -> [Nothing]+ fs -> [fs `index` c] +eval z (Rect r c r' c') = concat [ eval z (Cell i j) | i <- [r..r'] + , j <- [c..c'] ]+eval z (Row r) = concat [ eval z (Cell r j) + | j <- [0..length (z `at` 0)-1] ]+eval z (MarkNull f) = [ maybe (Just nULL_MARK) Just fi + | fi <- eval z f ]+eval z (Index f) = [ fi+++Just iNDEX_SUFFIX | fi <- eval z f ]+eval z (Cat fs) = concatMap (eval z) fs+eval z (Cart f f') = [ fmap Text.normalize $ fi +++ Just "," +++ fi' + | fi <- eval z f , fi' <- eval z f' ]+eval z (Lower f) = [ fmap (Text.map Char.toLower) fi | fi <- eval z f ]+eval z (Suffix i f) = [ fmap (Text.reverse+ . Text.take (fromIntegral i)+ . Text.reverse )+ $ fi | fi <- eval z f ]+eval z (Prefix i f) = [ fmap (Text.take (fromIntegral i)) $ fi + | fi <- eval z f ]+eval z (WordShape f) = [ fmap (spellingSpec) fi | fi <- eval z f ] ++spellingSpec = Text.fromString + . map (\(x:xs) -> x) + . group + . map collapse + . Text.toString++collapse c | Char.isAlpha c && Char.isUpper c = 'X'+ | Char.isAlpha c && Char.isLower c = 'x'+ | Char.isDigit c = '0'+ | c == '-' = '-'+ | c == '_' = '_'+ | otherwise = '*'++indexFeatures :: AtomTable -> IntSet.IntSet +indexFeatures =+ IntMap.keysSet + . IntMap.filter (iNDEX_SUFFIX `Text.isSuffixOf`) + . from ++inputFeatures :: Config -> ListZipper Token -> [Txt]+inputFeatures config x =+ catMaybes . prefixIndex iNPUT_PREFIX . eval x . featureTemplate $ config++outputFeatures :: [Txt] -> [Txt]+outputFeatures ys = catMaybes . prefixIndex oUTPUT_PREFIX . map Just $+ case ys of+ (y:y':_) -> [y,y`Text.append`y']+ [y] -> [y]+ [] -> []++features :: (Functor m, MonadAtoms m) => Maybe (Int,Int) -> Config + -> ListZipper Token + -> m (V.Vector Int)+features bounds config = do + case (flagHash . flags $ config,bounds) of+ (True,Just (_,size)) -> + return + . V.fromList + . map (toAtom' size)+ . inputFeatures config+ (False,Nothing) -> + fmap V.fromList + . mapM toAtom+ . inputFeatures config++maybeFeatures :: (Functor m, MonadAtoms m) => Maybe (Int,Int) -> Config + -> ListZipper Token + -> m (V.Vector Int)+maybeFeatures bounds config = do+ case (flagHash . flags $ config,bounds) of+ (True,Just _) -> features bounds config+ (False,Nothing) -> + fmap V.fromList + . fmap catMaybes+ . mapM maybeToAtom+ . inputFeatures config+prefixIndex :: Txt -> [Maybe Txt] -> [Maybe Txt]+prefixIndex str = zipWith (\i x -> Just str +++ Just (Text.show i) + +++ Just "=" + +++ x ) + [1..]++(+++) = liftM2 (\s t -> Text.concat [s,t])++index [] _ = Nothing+index (x:_) 0 = Just x+index (_:xs) i = index xs (i-1)+++sent = LZ.fromList [["I","pro"],["like","v"],["Ike","pn"]] :: ListZipper Token
− src/Perceptron/Sequence.hs
@@ -1,269 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction - , BangPatterns- , FlexibleInstances- #-}-module Perceptron.Sequence- (- Model(..)- , Options(..)- , Eval- , YMap- , train- , decode- )-where--import qualified Data.Array.Unsafe as AU-import Data.Array.ST-import Data.Array.Unboxed-import qualified Data.Array as A-import qualified Data.Vector.Unboxed as V-import Control.Monad.ST -import qualified Control.Monad.ST.Unsafe as ST.Unsafe-import Data.STRef-import Control.Monad-import qualified Data.Map as Map-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import Perceptron.Vector-import System.IO-import Debug.Trace-import Config -import Data.List (inits,foldl',sortBy)-import Data.Ord (comparing)-import Helper.ListZipper -import qualified Data.Binary as Binary-import Helper.Utils (uniq)--data Model = Model { options :: Options - , weights :: UArray I Float }-type X = [Xi]-type Y = [Yi]-type Xi = V.Vector Xii-type Xii = Int-type Yi = Int-type Dot = Local -> Float--data Options = Options { oYMap :: YMap- , oIndexSet :: IntSet.IntSet- , oYDict :: IntMap.IntMap [Yi]- , oYs :: [Yi]- , oBeam :: Int - , oRate :: Float- , oEpochs :: Int - , oFeatBounds :: Maybe (Int,Int)- } deriving Eq--type YMap = (Xi,A.Array Yi Xi,A.Array (Yi,Yi) Xi)--instance Binary.Binary (V.Vector Int) where- put v = Binary.put $ V.toList v- get = V.fromList `fmap` Binary.get- -instance Binary.Binary Model where- put m = do - Binary.put (options m)- -- Binary.put (weights m)- let (lo,hi) = bounds . weights $ m- xs = filter (\(_,e) -> e /= 0.0) . assocs . weights $ m- Binary.put (lo,hi)- Binary.put xs-- get = {-# SCC "get1" #-} do - os <- Binary.get - os == os `seq` return ()- ws <- do- (lo,hi) <- Binary.get- xs <- Binary.get- xs == xs `seq` return ()- return $ accumArray (+) 0 (lo,hi) $ xs- ws == ws `seq` return ()- return $ Model os ws--instance Binary.Binary Options where- put (Options a b c d e f g h) = Binary.put a >> Binary.put b >> Binary.put c - >> Binary.put d >> Binary.put e >> Binary.put f- >> Binary.put g >> Binary.put h- get = {-# SCC "get2" #-} do- a <- Binary.get- a == a `seq` return ()- b <- Binary.get- b == b `seq` return ()- c <- Binary.get - c == c `seq` return ()- d <- Binary.get - d == d `seq` return ()- e <- Binary.get- e == e `seq` return ()- f <- Binary.get- f == f `seq` return ()- g <- Binary.get- g == g `seq` return ()- h <- Binary.get- h == h `seq` return ()- return $ Options a b c d e f g h--yDictFind :: Options -> Xi -> [Yi]-yDictFind opts fs = - let mk = V.find (`IntSet.member` oIndexSet opts) $ fs- def = oYs opts- in case mk of- Just k -> IntMap.findWithDefault def k . oYDict $ opts- Nothing -> def---- | DECODING -decode :: Model -> X -> Y-decode m = fst . decode' (options m) (weights m `dot`) --data Cell = Cell { cScore :: !Float- , cPhi :: Global- , cPath :: Y- , cStep :: ListZipper Xi } deriving (Show,Eq)--decode' :: Options -> Dot -> X -> (Y,Global)-decode' opts w x = - bestPath opts w [Cell { cScore = 0 - , cPhi = Map.empty- , cPath = []- , cStep = fromList x } ]---phi :: Options -> X -> Y -> Global-phi opts x y = foldl' f Map.empty . zip x . map reverse . tail . inits $ y- where f z (xi,ys) = z `plus` toSV (features (oYMap opts) xi ys)--{-# INLINE features #-} -features :: YMap -> Xi -> [Yi] -> Local-features (!zero,uni,bi) xi (y:ys) = - case ys of- [] -> (Local y $ zero V.++ xi)- [y1] -> (Local y $ uni A.! y1 V.++ xi)- (y1 : y2 : _) -> let r = bi A.! (y1,y2) - in if V.null r - then (Local y $ uni A.! y1 V.++ xi)- else (Local y $ r V.++ xi)--beamSearch :: Options- -> Dot- -> [Cell] - -> [Cell]-beamSearch opts w cs = - let f cs = if any (atEnd . cStep) cs then cs - else - let cs' = [ let fs = features (oYMap opts) xi (y':ys)- in Cell { cScore = - s + w fs - , cPhi = ph `plus` (toSV fs)- , cPath = (y':ys)- , cStep = next x } - | Cell { cScore = s - , cPhi = ph - , cPath = ys - , cStep = x } <- cs - , let Just xi = focus x- , y' <- yDictFind opts xi- ]- in f . take (oBeam opts) - . sortBy (flip $ comparing cScore) - $ cs'- in f cs --bestPath :: Options- -> Dot- -> [Cell]- -> (Y, Global)-bestPath opts w xs = - let xs' = beamSearch opts w xs- first = (\(x:_) -> x) xs'- in ( reverse . cPath $ first- , cPhi first )---- | TRAINING--iter :: Options - -> Int- -> [(X,Y)]- -> (STRef s Int, WeightsST s, WeightsST s)- -> ST s ()-iter opts _ ss (c,params,params_a) = do- for_ ss $ \ (x,y) -> do- params' <- AU.unsafeFreeze params- let (y',phi_xy') = decode' opts (params'`dot`) x- when (y' /= y) $ do - let phi_xy = phi opts x y - update = (phi_xy `minus` phi_xy') `scale` oRate opts- params `plus_` update- c' <- readSTRef c- params_a `plus_` (update `scale` fromIntegral c')- modifySTRef c (+1)---type Eval = Int -> [(Y,Y)] -> [(Y,Y)] -> String--train :: Options -> [(X, Y)] -> Eval -> [(X,Y)] -> Model-train opts heldout eval ss = Model opts $ runSTUArray $ do- let bs = computeBounds opts ss- trace ("Param vector bounds: " ++ show bs) () `seq` return ()- params <- newArray bs 0- params_a <- newArray bs 0- c <- newSTRef 1- let undef = error "Perceptron.Sequence.train: undefined"- runLogger . hPutStrLn stderr $ eval 0 undef undef- for_ [1..oEpochs opts] $ - \i -> do iter opts i ss (c,params,params_a)- c' <- readSTRef c- params' <- AU.unsafeFreeze params- params_a' <- AU.unsafeFreeze params_a- let w = (fromIntegral c',params',params_a')- ys xys = [ fst . decode' opts (w`dot'`) $ x - | (x,_) <- xys ]- runLogger - . hPutStrLn stderr- $ eval i (zip (map snd ss) (ys ss))- (zip (map snd heldout) (ys heldout)) - - finalParams (c, params, params_a)- return params---{-# NOINLINE runLogger #-}-runLogger f = ST.Unsafe.unsafeIOToST f--finalParams :: (STRef s Int, WeightsST s, WeightsST s) - -> ST s ()-finalParams (c,params,params_a) = do- (l,u) <- getBounds params- c' <- fmap fromIntegral (readSTRef c)- for_ (range (l,u)) $ \i -> do- e <- readArray params i- e_a <- readArray params_a i- writeArray params i (e - (e_a * (1/c')))---computeBounds :: Options -> [(X,Y)] -> (I,I)-computeBounds opts xys = - let ((yl,xl),(yh,xh)) = foldl' f ((maxBound,minimum xis)- ,(minBound,maximum xis)) - . (\(xs,ys) -> zip (concat xs) (concat ys))- . unzip- $ xys- in case oFeatBounds opts of- Just (xl',xh') -> (I yl xl',I yh xh')- Nothing -> (I yl xl,I yh xh)- where f ((!miny,!minx),(!maxy,!maxx)) (xs,!y) =- ((min miny y,V.minimum $ minx`V.cons`xs)- ,(max maxy y,V.maximum $ maxx`V.cons`xs))- xis = let (zero,uni,bi) = oYMap opts- in uniq- . concatMap V.toList- $- [zero]- ++- (filter (not . V.null)- . A.elems- $ bi)- ++- (filter (not . V.null) - . A.elems - $ uni)-
− src/Perceptron/Vector.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE FlexibleContexts , BangPatterns #-}-module Perceptron.Vector - ( I(..)- , Global- , Local(..)- , Weights- , WeightsST- , toSV- , for_- , plus_- , minus_- , plus- , minus- , scale- , dot - , dot'- )-where--import Data.Array.ST-import Data.Array.Unboxed-import Control.Monad.ST-import Data.STRef-import Control.Monad-import qualified Data.Map as Map-import Data.List (foldl',sort)-import qualified Data.Vector.Unboxed as V-import Data.Binary--data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Int deriving (Eq,Ord,Ix,Show)-instance Binary I where - put (I i j) = put (i,j)- get = uncurry I `fmap` get--type Global = Map.Map I Float-data Local = Local {-# UNPACK #-} !Int !(V.Vector Int)-type WeightsST s = STUArray s I Float-type Weights = UArray I Float----for_ xs f = mapM_ f xs--plus_ :: WeightsST s -> Global -> ST s ()-plus_ w v = do- for_ (Map.toList v) $ \(i,vi) -> do- wi <- readArray w i - writeArray w i (wi + vi)-minus_ w v = plus_ w (v `scale` (-1))--scale :: Global -> Float -> Global-scale v n = Map.map (*n) v--plus :: Global -> Global -> Global-plus u v = Map.unionWith (+) u v-minus :: Global -> Global -> Global-minus u v = u `plus` (v `scale` (-1))---dot :: Weights -> Local -> Float-{-# INLINE dot #-}-dot w (Local !y x) = V.foldl' (\ !z !i -> z + w ! I y i) 0 x--- For some reason explicit loop doesn't help here--- dot !w (Local y x) = go 0 0--- where !len = V.length x--- go !z !j | j == len = z--- go !z !j = go (z + w ! I y (x V.! j)) (j+1)---dot' :: (Float,Weights,Weights) -> Local -> Float-{-# INLINE dot' #-}--- dot' (!c,!params,!params_a) (Local y x) = V.foldl' (\ !z !j -> --- let i = I y j--- e = params ! i --- e_a = params_a ! i--- in z + (e - (e_a / c)))--- 0--- x---dot' (!c,!params,!params_a) (Local y x) = go 0 0- where !len = V.length x- go !z !j | j == len = z- go !z !j = - let i = I y (x V.! j)- e = params ! i- e_a = params_a ! i- in go (z + (e - (e_a / c))) (j+1)--toSV :: (V.Unbox Int) => Local -> Global-toSV (Local y v) = Map.fromList [ (I y i,1) | i <- V.toList v ]
− src/ghc_rts_opts.c
@@ -1,1 +0,0 @@-char *ghc_rts_opts = "-K100m -H500m";
+ src/sequor.hs view
@@ -0,0 +1,98 @@+module Main (main)+where+import qualified NLP.Sequor as L +import NLP.Sequor.CoNLL+import qualified Helper.Text as Text+import qualified Helper.ListZipper as Z+import qualified Data.Binary as Binary+import qualified Data.ByteString.Lazy as ByteString+import System.Environment (getArgs)+import System.IO (hPutStrLn,stderr)+import Helper.Commands ( CommandSpec (..),defaultMain , usage + , Command+ , OptDescr(Option), ArgDescr(ReqArg,NoArg))+import NLP.Sequor.Config(Flags(..))+import Text.Printf++commands :: [(String, CommandSpec Flags)] +commands = + [ ("train", CommandSpec train "train model"+ [ Option [] ["rate"] + (ReqArg (\a o -> o { flagRate = read a }) "NUM (0.01)")+ "learning rate"+ , Option [] ["beam"] + (ReqArg (\a o -> o { flagBeam = read a }) "INT (10)")+ "beam size"+ , Option [] ["iter"] + (ReqArg (\a o -> o { flagIter = read a }) "INT (10)")+ "number of iterations"+ , Option [] ["min-count"] + (ReqArg (\a o -> o { flagMinFeatCount = read a }) "INT (100)")+ "minimum feature frequency for label dictionary"+ , Option [] ["heldout"]+ (ReqArg (\a o -> o { flagHeldout = Just a }) "FILE")+ "path to heldout data"+ , Option [] ["hash"] + (NoArg (\o -> o { flagHash = True }))+ "use hashing instead of feature dictionary"+ , Option [] ["hash-sample"] + (ReqArg (\a o -> o { flagHashSample = read a }) "INT (1000)")+ "sample size to estimate number of features when hashing"+ , Option [] ["hash-max-size"] + (ReqArg (\a o -> o { flagHashMaxSize + = Just $ read a }) "INT")+ "maximum size of parameter vector when hashing" + , Option [] ["stop-win-size"] + (ReqArg (\a o -> o { flagStopWinSize = read a }) "INT (5)")+ "size of window of iterations when checking convergence" + , Option [] ["stop-threshold"] + (ReqArg (\a o -> o { flagStopThreshold = read a }) "FLOAT (0.05)")+ "threshold of error change when checking convergence " + + ]+ ["TEMPLATE-FILE","TRAIN-FILE","MODEL-FILE"])+ , ("predict", CommandSpec predict "predict using model" []+ ["MODEL-FILE"])+ , ("version", CommandSpec version "print version" [] [])+ , ("help" , CommandSpec help "print usage information" [] [])+ ]+ +train :: Command Flags+train flags [templatef,trainf,outf] = do+ template <- L.parseTemplate `fmap` Text.readFile templatef+ traindat <- (map toLabeled . parse) `fmap` Text.readFile trainf+ testdat <- case flagHeldout flags of+ Nothing -> return []+ Just testf -> (map toLabeled . parse) `fmap` Text.readFile testf+ let (m, info) = L.train flags template traindat testdat + putStr . formatTrace $ info+ ByteString.writeFile outf . Binary.encode $ m++predict :: Command Flags+predict flags [modelf] = do+ m <- Binary.decode `fmap` ByteString.readFile modelf+ testdat <- parse `fmap` Text.getContents+ Text.putStr + . Text.unlines + . map Text.unlines + . L.predict m+ $ testdat++-- | Format sequence of error rates on train and development data+formatTrace :: L.Trace -> String+formatTrace scores =+ unlines $ [ printf "%10s %10s %10s %10s" "Iter" "Err_train" "Err_heldout" "Rel_change"]+ ++ [ printf "%10d %10.5f %10.5f %10.5f" i err_train err_dev ch + | (i,(err_train, err_dev, ch)) <- zip [(1::Int) ..] scores ]+ +version :: Command Flags +version _ _ = putStrLn "sequor-0.2.2"++help :: Command Flags+help _ _ = usage commands msg []++main :: IO () +main = defaultMain L.defaultFlags commands msg++msg = "Usage: sequor command [OPTION...] [ARG...]"+