diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -1,6 +1,6 @@ -sequor 0.1 +sequor 0.2 -AUTHOR: Grzegorz Chrupała +AUTHOR: Grzegorz Chrupała 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. diff --git a/lib/haskell-utils/Commands.hs b/lib/haskell-utils/Commands.hs new file mode 100644 --- /dev/null +++ b/lib/haskell-utils/Commands.hs @@ -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)) + diff --git a/sequor.cabal b/sequor.cabal --- a/sequor.cabal +++ b/sequor.cabal @@ -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 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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 diff --git a/src/Features.hs b/src/Features.hs --- a/src/Features.hs +++ b/src/Features.hs @@ -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 "=" diff --git a/src/Labeler.hs b/src/Labeler.hs --- a/src/Labeler.hs +++ b/src/Labeler.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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...]" diff --git a/src/Perceptron/Sequence.hs b/src/Perceptron/Sequence.hs --- a/src/Perceptron/Sequence.hs +++ b/src/Perceptron/Sequence.hs @@ -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)) diff --git a/src/Perceptron/Vector.hs b/src/Perceptron/Vector.hs --- a/src/Perceptron/Vector.hs +++ b/src/Perceptron/Vector.hs @@ -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 diff --git a/src/ghc_rts_opts.c b/src/ghc_rts_opts.c new file mode 100644 --- /dev/null +++ b/src/ghc_rts_opts.c @@ -0,0 +1,1 @@ +char *ghc_rts_opts = "-K100m";