sequor 0.1 → 0.2
raw patch · 11 files changed
+295/−118 lines, 11 filesdep +hashabledep +pretty
Dependencies added: hashable, pretty
Files
- Makefile +1/−1
- README +22/−27
- lib/haskell-utils/Commands.hs +63/−0
- sequor.cabal +5/−3
- src/Config.hs +22/−7
- src/Features.hs +32/−13
- src/Labeler.hs +44/−20
- src/Main.hs +87/−39
- src/Perceptron/Sequence.hs +15/−6
- src/Perceptron/Vector.hs +3/−2
- src/ghc_rts_opts.c +1/−0
Makefile view
@@ -7,7 +7,7 @@ svn co http://ws9lx.lsv.uni-saarland.de/repos/gchrupala/haskell-utils/ lib/haskell-utils run: lib/haskell-utils- ghc --make -O2 -isrc:$(INCLUDES) -o bin/sequor src/Main.hs+ ghc --make -O2 -isrc:$(INCLUDES) -o bin/sequor src/ghc_rts_opts.c src/Main.hs clean: -find . -name '*.o' | xargs rm
README view
@@ -1,6 +1,6 @@-sequor 0.1+sequor 0.2 -AUTHOR: Grzegorz Chrupała <pitekus@gmail.com>+AUTHOR: Grzegorz Chrupała <gchrupala@lsv.uni-saarland.de> Sequor is a sequence labeler based on Collins's sequence perceptron. Sequor has a flexible feature template language and is@@ -17,39 +17,34 @@ example to learn Part of Speech tagging, syntactic chunking or Named Entity labeling. -In order to learn a model from labeled data call sequor like this:--sequor train FEATURE-TEMPLATE LEARNING-RATE BEAM-SIZE MAX-ITERATIONS \- MIN-DICT-COUNT TRAIN-FILE HELDOUT-FILE MODEL-FILE-FEATURE-TEMPLATE - specification of which features to use. For an - example see data/AllFeatures.txt-LEARNING-RATE - positive number (=<1) which controls how fast learning is- 0.1 is a reasonable default-BEAM-SIZE - positive integer controlling the size of the beam. -ITERATIONS - positive integer controlling for how many iterations to train-MIN-DICT-COUNT - positive integer specifying how many times an indexed - feature has to use the label dictionary for this feature. - Using a large number will effectively disable use of label- dictionary-TRAIN-FILE - annotated data in CoNLL format. Sequences separated by - blank lines, features separated by space-HELDOUT-FILE - annotated heldout data. To disable use an empty file - (/dev/null) -MODEL-FILE - name of the file where the learned model will be stored-+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 +predict: predict using model+predict MODEL-FILE -In order to apply the learned model to new data, call:+version: print version+version -sequor predict MODEL-FILE < NEW-DATA > NEW-LABELS+help: print usage information+help Data files should be in the UTF-8 encoding. As an example we can use data annotated with syntactic chunk labels in the data directory. For example: -./bin/sequor train data/all.features 0.1 10 5 50 \- data/train.conll data/devel.conll model+./bin/sequor train data/all.features data/train.conll data/devel.conll model\+ --rate 0.1 --beam 10 --iter 5 --min-count 50 --hash ./bin/sequor predict model < data/test.conll > data/test.labels @@ -76,7 +71,7 @@ use. As an example consider the following template: Cat [ Cell 0 0, Suffix 2 (Cell 0 0), Row -1, Row 1 ]. It specifies the following features: the first field in the current-token, the two-characted suffix of the first field of the current+token, the two-character suffix of the first field of the current token, all the fields of the previous token and all the fields of the following token.
+ lib/haskell-utils/Commands.hs view
@@ -0,0 +1,63 @@+module Commands + ( Command+ , CommandName+ , Help+ , CommandSpec (..)+ , module System.Console.GetOpt+ , defaultMain+ , usage+ )+where+import Text.PrettyPrint(renderStyle,render,nest,vcat,hsep,style+ ,Mode(..),mode,text,(<>),($$),($+$),(<+>))+import System.Console.GetOpt+import System.Environment (getArgs)+import System.IO (stderr)+import System.IO.UTF8 (hPutStr)+import qualified Data.List as List+++type Command opts = (opts -> [String] -> IO ())+type CommandName = String+type Help = String+data CommandSpec opts = CommandSpec (Command opts)+ Help + [OptDescr (opts -> opts)]+ [String]++defaultMain :: opts -> [(String, CommandSpec opts)] -> String -> IO ()+defaultMain def commands header = do+ args <- getArgs+ let theUsage = usage commands header+ case args of+ [] -> theUsage []+ command:opts -> case List.lookup command commands of+ Nothing -> theUsage ["Invalid command: " ++ command]+ Just spec -> runCommand theUsage def spec opts++runCommand :: ([String] -> IO ()) + -> opts + -> CommandSpec opts + -> [String] + -> IO ()+runCommand theUsage def (CommandSpec command help optDesc argnames) args = + case getOpt Permute optDesc args of+ (o,n,[] ) -> command (foldr ($) def o) n+ (_,_,errs) -> theUsage errs++usage :: [(String, CommandSpec t)] -> String -> [String] -> IO ()+usage commands header errs = hPutStr stderr . render + $ vcat (List.map text errs)+ $$ usageMsg commands header++usageMsg commands header = + text header+ $+$ (vcat (List.map commandUsage commands))++commandUsage (name , CommandSpec command help optionDesc args) = + text name <> text ":"+ $$ (nest 10 (text help))+ $$ (text name <+> text (if null optionDesc then "" else "[OPTION...]")+ <+> hsep (map text args))+ <+> (nest 10 (text $ usageInfo "" optionDesc))+
sequor.cabal view
@@ -1,5 +1,5 @@ Name: sequor-Version: 0.1+Version: 0.2 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/@@ -19,10 +19,12 @@ Main-is: Main.hs Other-modules: ListZipper, Utils, Text, CorpusReader, Atom, FeatureTemplate, Config, Perceptron.Vector,- Perceptron.Sequence, Features, Labeler+ Perceptron.Sequence, Features, Labeler, Commands Build-Depends: base >= 3 && < 5, containers >= 0.2, bytestring >= 0.9, utf8-string >= 0.3, binary >= 0.5, mtl >= 1.1,- vector >= 0.5, array >= 0.2+ vector >= 0.5, array >= 0.2, pretty >= 1.0,+ hashable >= 1.0 hs-source-dirs: src,lib/haskell-utils ghc-options: -O2+ c-sources: src/ghc_rts_opts.c
src/Config.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Config - ( Config (..) )+ ( Config (..), Flags(..) ) where import Data.Char import Atom (AtomTable)@@ -8,16 +8,31 @@ import Control.Monad (ap) import FeatureTemplate (Feature) -data Config = Config { wordMinCount :: Int- , atomTable :: AtomTable - , minLabelFreq :: Int++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 } +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 + in return Config `ap` g `ap` g `ap` g - put (Config a b c d) =+ put (Config a b c) = let p = B.put - in p a >> p b >> p c >> p d + in p a >> p b >> p c
src/Features.hs view
@@ -2,10 +2,11 @@ module Features ( features+ , maybeFeatures , inputFeatures , outputFeatures , indexFeatures- , maybeFeatures , eval + , eval ) where @@ -25,7 +26,11 @@ import Config import qualified Data.Vector.Unboxed as V import FeatureTemplate (Feature(..))- +import Data.Hashable (hash)+import Data.Word (Word)++toAtom' size s = hash s `mod` size+ iNDEX_SUFFIX :: Txt iNDEX_SUFFIX="::index" iNPUT_PREFIX :: Txt@@ -89,18 +94,32 @@ [y] -> [y] [] -> [] -features :: (MonadAtoms m) => Config -> ListZipper Token -> m (V.Vector Int)-features config x = do- ifs <- mapM toAtom (inputFeatures config x)- return $ V.fromList ifs--maybeFeatures :: (MonadAtoms m) => - Config -> ListZipper Token -> m (V.Vector Int)-maybeFeatures config x = do- ifs <- mapM maybeToAtom (inputFeatures config x)- return (V.fromList $ catMaybes $ ifs)-+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 "="
src/Labeler.hs view
@@ -22,7 +22,8 @@ import Text.Printf import Atom import Control.Monad.RWS-import Features (maybeFeatures,features,outputFeatures,indexFeatures)+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@@ -32,6 +33,7 @@ import Data.Maybe (catMaybes) import Config + data ModelData = ModelData { model :: P.Model , config :: Config } @@ -44,23 +46,20 @@ -- Main exported functions predict :: ModelData -> [[ListZipper Token]] -> [[Txt]]-predict m testdat = - fst . flip runAtoms (atomTable . config $ m) $+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 (config m)) $ x+ do x' <- mapM (maybeFeatures bounds (config m)) $ x predict' (P.decode (model m)) $ x' train :: Config - -> Float- -> Int - -> Int -> [([ListZipper Token],[Txt])] -> [([ListZipper Token],[Txt])] -> ModelData-train conf rate limit beam traindat heldout = +train conf traindat heldout = let ((m,_predicted),_atoms) = runAtoms (run conf - (rate,limit,beam) traindat heldout) $ empty@@ -100,28 +99,35 @@ run :: (Functor m, MonadAtoms m) => Config- -> (Float, Int,Int) -> [([ListZipper Token], [Txt])] -> [([ListZipper Token], [Txt])] -> m (ModelData, [[Txt]])-run conf (rate, limit,beamp) trainset_in_full testset_in = do- let trainset_in = pruneLabels (minLabelFreq conf) trainset_in_full+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- trainset <- mapM (mkfs $ features conf) trainset_in outm <- mkOutputFeatureAtoms . map snd $ trainset_in - testset <- mapM (mkfs $ maybeFeatures conf) testset_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 - (wordMinCount conf') trainset+ (flagMinFeatCount . flags $ conf') trainset , oYs = ys'- , oBeam = beamp- , oRate = rate- , oEpochs = limit+ , 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@@ -158,11 +164,17 @@ . 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 -> m (V.Vector F)) -> ([ListZipper Token], [Txt]) - -> m ([V.Vector F], [Tag])+ -> m ([V.Vector F], [Tag]) mkfs f (x,y) = do fs <- mapM f x fs == fs `seq` return ()@@ -170,6 +182,18 @@ 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)
src/Main.hs view
@@ -1,49 +1,97 @@ module Main (main) where-import Labeler (Config(..),ModelData(..)- ,train,predict)+import qualified Labeler as L import CorpusReader (corpus,corpusLabeled) import qualified Text import qualified Data.Binary as Binary import System.Environment (getArgs) import System.IO (hPutStrLn,stderr) import FeatureTemplate (parse)+import Commands ( CommandSpec (..),defaultMain , usage + , Command+ , OptDescr(Option), ArgDescr(ReqArg,NoArg))+import Config(Flags(..)) -main :: IO ()-main = do- (command:args) <- getArgs- case command of- "train" -> do - let [ templatef- ,rate- ,beamp- ,limit- ,mincount- ,trainf- ,testf- ,outf- ] = args- template <- parse `fmap` Text.readFile templatef- traindat <- fmap corpusLabeled $ Text.readFile trainf- testdat <- fmap corpusLabeled $ Text.readFile testf- let conf = Config { featureTemplate = template - , wordMinCount = read mincount- , atomTable = error - "main:Config.atomTable undefined" - , minLabelFreq = 1- }- Text.writeFile outf - . Binary.encode - . train conf (read rate) (read limit) (read beamp) traindat - $ testdat- "predict" -> do- let [modelf] = args- m <- fmap Binary.decode (Text.readFile modelf)- testdat <- fmap corpus $ Text.getContents- Text.putStr - . Text.unlines - . map Text.unlines - . predict m- $ testdat- _ -> hPutStrLn stderr "Invalid command" +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 conf = L.Config { L.featureTemplate = template + , L.atomTable = error + "main:Config.atomTable undefined" + , L.flags = flags+ }+ Text.writeFile outf + . Binary.encode + . L.train conf traindat + $ testdat++predict :: Command Flags+predict flags [modelf] = do+ m <- fmap Binary.decode (Text.readFile modelf)+ testdat <- fmap corpus $ Text.getContents+ Text.putStr + . Text.unlines + . map Text.unlines + . L.predict m+ $ testdat++version :: Command Flags +version _ _ = putStrLn "sequor-0.2"++help :: Command Flags+help _ _ = usage commands msg []++main :: IO () +main = defaultMain defaultFlags commands msg++msg = "Usage: sequor command [OPTION...] [ARG...]"
src/Perceptron/Sequence.hs view
@@ -4,7 +4,7 @@ #-} module Perceptron.Sequence (- Model+ Model(..) , Options(..) , Eval , YMap@@ -50,6 +50,7 @@ , oBeam :: Int , oRate :: Float , oEpochs :: Int + , oFeatBounds :: Maybe (Int,Int) } deriving Eq type YMap = (Xi,A.Array Yi Xi,A.Array (Yi,Yi) Xi)@@ -79,9 +80,9 @@ return $ Model os ws instance Binary.Binary Options where- put (Options a b c d e f g) = Binary.put a >> Binary.put b >> Binary.put c + 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 g >> Binary.put h get = {-# SCC "get2" #-} do a <- Binary.get a == a `seq` return ()@@ -97,7 +98,9 @@ f == f `seq` return () g <- Binary.get g == g `seq` return ()- return $ Options a b c d e f g+ h <- Binary.get+ h == h `seq` return ()+ return $ Options a b c d e f g h yDictFind :: Options -> Xi -> [Yi] yDictFind opts fs = @@ -199,7 +202,7 @@ train :: Options -> [(X, Y)] -> Eval -> [(X,Y)] -> Model train opts heldout eval ss = Model opts $ runSTUArray $ do let bs = computeBounds opts ss- trace (show bs) () `seq` return ()+ trace ("Param vector bounds: " ++ show bs) () `seq` return () params <- newArray bs 0 params_a <- newArray bs 0 c <- newSTRef 1@@ -235,11 +238,17 @@ e_a <- readArray params_a i writeArray params i (e - (e_a * (1/c'))) + computeBounds :: Options -> [(X,Y)] -> (I,I)-computeBounds opts = foldl' f ((maxBound,minimum xis)+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') -> ((yl,xl'),(yh,xh'))+ Nothing -> ((yl,xl),(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))
src/Perceptron/Vector.hs view
@@ -26,6 +26,7 @@ import Config import qualified Data.Vector.Unboxed as V + type SparseVector i = Map.Map i Float type LocalSparseVector y i = (y,V.Vector i) type DenseVectorST s i = STUArray s i Float@@ -38,8 +39,8 @@ plus_ :: (Show i,Ix i) => DenseVectorST s i -> SparseVector i -> ST s () plus_ w v = do for_ (Map.toList v) $ \(i,vi) -> do- wi <- readArray w i - writeArray w i (wi + vi)+ wi <- readArray w i + writeArray w i (wi + vi) minus_ w v = plus_ w (v `scale` (-1)) scale :: (Ix i) => SparseVector i -> Float -> SparseVector i
+ src/ghc_rts_opts.c view
@@ -0,0 +1,1 @@+char *ghc_rts_opts = "-K100m";