diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -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 diff --git a/lib/Helper/ListZipper.hs b/lib/Helper/ListZipper.hs --- a/lib/Helper/ListZipper.hs +++ b/lib/Helper/ListZipper.hs @@ -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 diff --git a/sequor.cabal b/sequor.cabal --- a/sequor.cabal +++ b/sequor.cabal @@ -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 + diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -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 diff --git a/src/CorpusReader.hs b/src/CorpusReader.hs deleted file mode 100644 --- a/src/CorpusReader.hs +++ /dev/null @@ -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 - - diff --git a/src/FeatureTemplate.hs b/src/FeatureTemplate.hs deleted file mode 100644 --- a/src/FeatureTemplate.hs +++ /dev/null @@ -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 - diff --git a/src/Features.hs b/src/Features.hs deleted file mode 100644 --- a/src/Features.hs +++ /dev/null @@ -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 = "" - - -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 diff --git a/src/Labeler.hs b/src/Labeler.hs deleted file mode 100644 --- a/src/Labeler.hs +++ /dev/null @@ -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) diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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...]" - diff --git a/src/NLP/Perceptron/Sequence.hs b/src/NLP/Perceptron/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Perceptron/Sequence.hs @@ -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) + diff --git a/src/NLP/Perceptron/Vector.hs b/src/NLP/Perceptron/Vector.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Perceptron/Vector.hs @@ -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 ] diff --git a/src/NLP/Sequor.hs b/src/NLP/Sequor.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Sequor.hs @@ -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 diff --git a/src/NLP/Sequor/CoNLL.hs b/src/NLP/Sequor/CoNLL.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Sequor/CoNLL.hs @@ -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)) diff --git a/src/NLP/Sequor/Config.hs b/src/NLP/Sequor/Config.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Sequor/Config.hs @@ -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 diff --git a/src/NLP/Sequor/FeatureTemplate.hs b/src/NLP/Sequor/FeatureTemplate.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Sequor/FeatureTemplate.hs @@ -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 + diff --git a/src/NLP/Sequor/Features.hs b/src/NLP/Sequor/Features.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Sequor/Features.hs @@ -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 = "" + + +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 diff --git a/src/Perceptron/Sequence.hs b/src/Perceptron/Sequence.hs deleted file mode 100644 --- a/src/Perceptron/Sequence.hs +++ /dev/null @@ -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) - diff --git a/src/Perceptron/Vector.hs b/src/Perceptron/Vector.hs deleted file mode 100644 --- a/src/Perceptron/Vector.hs +++ /dev/null @@ -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 ] diff --git a/src/ghc_rts_opts.c b/src/ghc_rts_opts.c deleted file mode 100644 --- a/src/ghc_rts_opts.c +++ /dev/null @@ -1,1 +0,0 @@ -char *ghc_rts_opts = "-K100m -H500m"; diff --git a/src/sequor.hs b/src/sequor.hs new file mode 100644 --- /dev/null +++ b/src/sequor.hs @@ -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...]" +