morfette 0.3.5 → 0.3.6
raw patch · 15 files changed
+382/−234 lines, 15 filesdep +textdep +vector
Dependencies added: text, vector
Files
- morfette.cabal +8/−4
- src/GramLab/FeatureSet.hs +1/−0
- src/GramLab/Morfette/BinaryInstances.hs +9/−0
- src/GramLab/Morfette/Evaluation.hs +3/−1
- src/GramLab/Morfette/Features/Common.hs +2/−2
- src/GramLab/Morfette/LZipper.hs +6/−0
- src/GramLab/Morfette/Models.hs +0/−145
- src/GramLab/Morfette/Models2.hs +152/−0
- src/GramLab/Morfette/Token.hs +59/−13
- src/GramLab/Morfette/Utils.hs +64/−35
- src/GramLab/Perceptron/Multiclass.hs +0/−1
- src/GramLab/Perceptron/Vector.hs +2/−6
- src/Lemma.hs +27/−14
- src/Main.hs +20/−4
- src/POS.hs +29/−9
morfette.cabal view
@@ -1,5 +1,5 @@ Name: morfette-Version: 0.3.5+Version: 0.3.6 Homepage: http://sites.google.com/site/morfetteweb/ Synopsis: A tool for supervised learning of morphology Description: Morfette is a tool for supervised learning of inflectional@@ -9,7 +9,7 @@ License: BSD3 License-file: LICENSE Author: Grzegorz Chrupała-Maintainer: Grzegorz Chrupała <gchrupala@lsv.uni-saarland.de>+Maintainer: Grzegorz Chrupała <grzegorz.chrupala@gmail.com> build-type: Simple category: Natural Language Processing Extra-source-files: README, INSTALL, Makefile@@ -27,14 +27,18 @@ GramLab.Perceptron.IntModel, GramLab.Morfette.Evaluation, GramLab.Morfette.Lang.Conf, GramLab.Morfette.MWE, GramLab.FeatureSet, GramLab.Perceptron.Model, - GramLab.Morfette.Config, GramLab.Morfette.Models, + GramLab.Morfette.Config, GramLab.Morfette.Models2, GramLab.Morfette.Settings.Defaults, GramLab.Morfette.Features.Common, Lemma, POS, GramLab.Morfette.Utils,+ GramLab.Morfette.BinaryInstances Paths_morfette Build-depends: base >=3 && <=5 , containers, array, mtl, directory, filepath, pretty,- utf8-string, bytestring, binary, QuickCheck >= 2.3+ utf8-string, bytestring, binary, QuickCheck >= 2.3,+ vector >= 0.10, text >= 0.11 cc-options: -Wall c-sources: src/ghc_rts_opts.c ghc-options: -O2 -rtsopts+-- uncomment the following line to link statically+-- ld-options: -static -pthread
src/GramLab/FeatureSet.hs view
@@ -51,6 +51,7 @@ -> State (Table (Int, Maybe String)) [(Int, Double)] #-} realFeature k Null = return [] realFeature k (Sym s) = intern (k,Just s) >>= \i -> return $ [(i,1)]+realFeature k (Num 0) = return [] realFeature k (Num n) = intern (k,Nothing) >>= \i -> return $ [(i,n)] realFeature k (Set ss) = mapM intern (zip (repeat k) (map Just (Utils.uniq ss))) >>= \is -> return $ zip is (repeat 1)
+ src/GramLab/Morfette/BinaryInstances.hs view
@@ -0,0 +1,9 @@+module GramLab.Morfette.BinaryInstances +where+import Data.Binary+import Control.Monad (liftM)+import qualified Data.Vector.Unboxed as U++instance (U.Unbox a, Binary a) => Binary (U.Vector a) where+ put v = put (U.toList v)+ get = liftM U.fromList get
src/GramLab/Morfette/Evaluation.hs view
@@ -41,7 +41,9 @@ sentenceAccuracy xs ys bl = accuracy (map,map,map) (map (map tokToPair) xs) (map (map tokToPair) ys) (fmap (map (map tokToPair)) bl)-tokToPair (form,lemma,pos) = (lowercase $ fromMaybe form lemma,pos)++tokToPair :: Token -> (String, Maybe String)+tokToPair t = (lowercase $ fromMaybe (tokenForm t) (tokenLemma t), tokenPOS t) accuracy (g,h,i) gold test mbl = Acc { lemmaAcc = AccBL (correct (g fst) test) (fmap (correct (g fst)) mbl)
src/GramLab/Morfette/Features/Common.hs view
@@ -5,7 +5,7 @@ , mapSym , mapNum , getSome- , module GramLab.Morfette.Models+ , module GramLab.Morfette.Models2 , module GramLab.Morfette.Settings.Defaults , module GramLab.Morfette.LZipper , module GramLab.FeatureSet@@ -22,7 +22,7 @@ import Data.Binary import Control.Monad (liftM,liftM2) import GramLab.Morfette.Settings.Defaults-import GramLab.Morfette.Models+import GramLab.Morfette.Models2 import GramLab.Morfette.LZipper import GramLab.Morfette.Lang.Conf
src/GramLab/Morfette/LZipper.hs view
@@ -14,8 +14,14 @@ import Debug.Trace data LZipper a b c = LZ [a] (Maybe b) [c] deriving (Show,Eq,Ord)++left :: LZipper t t1 t2 -> [t] left (LZ xs _ _) = xs++focus :: LZipper t t1 t2 -> Maybe t1 focus (LZ _ x _) = x++right :: LZipper t t1 t2 -> [t2] right (LZ _ _ ys) = ys fromList [] = LZ [] Nothing []
− src/GramLab/Morfette/Models.hs
@@ -1,145 +0,0 @@-module GramLab.Morfette.Models ( train- , trainFun- , predict - , predictPipeline- , toModelFun- , mkPreprune- , sentToExamples- , FeatureSpec (..)- , Smth(..)- , Tok- )-where-import GramLab.Morfette.LZipper-import qualified Data.Map as Map-import Data.Map ((!))-import Data.List (sortBy,foldl',transpose)-import Data.Ord (comparing)-import Data.Dynamic-import GramLab.FeatureSet-import qualified GramLab.Perceptron.Model as M-import Data.Traversable (forM)-import qualified Data.IntMap as IntMap-import Data.Maybe (fromMaybe)-import Debug.Trace-import Data.Binary-import Control.Monad (liftM)-import GramLab.Utils (uniq)--data Smth a = Str { str :: String } | ES { es :: a } deriving (Eq,Ord,Show,Read)-instance Binary a => Binary (Smth a) where- put (Str s) = put (0::Word8) >> put s- put (ES s) = put (1::Word8) >> put s- get = do- tag <- get- case tag::Word8 of- 0 -> liftM Str get- 1 -> liftM ES get--type ProbDist a = [(a,Double)]--type Tok a = [Smth a]-type Model a = LZipper [Smth a] [Smth a] [Smth a] -> ProbDist (Smth a)-beamSearch :: - Int -- beam size- -> [Model a]- -> ProbDist (LZipper (Tok a) (Tok a) (Tok a)) - -- prob dist over sequence of "tokens in context" (as lzippers)- -> ProbDist [Tok a] -- prob dist over sequences of "tokens"-beamSearch n cfs pzs =- if any (atEnd . fst) pzs - -- of any lzipper at end then get then return tokens- then flip map pzs $ \(z,p) -> (map id (reverse (left z)),p)- else -- otherwise apply each classifier in turn in the lzipper seq,- -- prune, adjust probs- let f pzs' model = prune n - . flip concatMap pzs'- $ \(z,p) -> - flip map (model $ z) - $ \(c,c_p) -> - (modify (\x -> x ++ [c]) z,p*c_p)- in beamSearch n cfs . map (\(z,p) -> (slide z,p)) $! (foldl f pzs cfs)---- pruning and prepruning--prune :: Int -> ProbDist a -> ProbDist a-prune n = take n . sortBy (flip (comparing snd))-collectUntil cond f z [] = []-collectUntil cond f z (x:xs) = let z' = (f $! x) $! z - in if cond x z' then []- else x: collectUntil cond f z' xs-mkPreprune th = collectUntil (\x z -> th > snd x / z) ((+) . snd) 0--data FeatureSpec a = - FS { label :: Tok a -> Smth a- , features :: LZipper (Tok a) (Tok a) (Tok a) -> [Feature String Double] - , preprune :: ProbDist (Smth a) -> ProbDist (Smth a)- , check :: LZipper (Tok a) (Tok a) (Tok a) -> Smth a -> Bool - , trainSettings :: M.TrainSettings }--trainFun :: (Ord a,Show a) => [FeatureSpec a] -> [[Tok a]] -> [Model a]-trainFun fspecs sents = - let ms = train fspecs sents- in (zipWith toModelFun fspecs ms) - -train :: (Ord a,Show a) => - [FeatureSpec a] - -> [[Tok a]] - -> [M.Model (Label a) Int String Double]-train fspecs sents = - flip map fspecs- $ \fs -> let yxs = concatMap (sentToExamples fs) $ sents- ys = uniq . map fst $ yxs- zs = concat [ take (length s) - . iterate slide - . fromList- $ s - | s <- sents ]- yss = [ [ y | y <- ys , check fs z y ] - | z <- zs ]- in M.train (trainSettings fs) yss yxs--toModelFun :: (Ord a,Show a) => - FeatureSpec a - -> (M.Model (Label a) Int String Double) - -> Model a-toModelFun fs m = - let ys = Map.keys . M.classMap . M.modelData $ m- in- \ z -> case filter (check fs z) ys of- [] -> error "GramLab.Morfette.Models.toModelFun: unexpected []"- y:ys' -> - preprune fs - . M.distribution m (y:ys')- . features fs - $ z - -predict :: Int -> Int -> [Model a] -> [[Tok a]] -> [[[Tok a]]]-predict k beamSize models sents = map predictK sents- where predictK s = transpose - . map fst - . take k- . beamSearch beamSize models - $ [(fromList s,1)]--predictPipeline :: Int -> [Model a] -> [[Tok a]] -> [[Tok a]]-predictPipeline beamSize models sents = map predictK sents- where predictK s = foldl' (\s1 m -> fst . head . beamSearch beamSize [m] - $ [(fromList s1,1)]) s models- --type Label a = Smth a-sentToExamples :: FeatureSpec a - -> [Tok a] - -> [(Label a,[Feature String Double])]-sentToExamples fs xs = slideThru f (fromList xs)- where f z = - ( label fs - . fromMaybe- (error "GramLab.Morfette.Models.sentToExample:fromMaybe")- . focus - $ z- , features fs z)- -slideThru f z | atEnd z = []-slideThru f z = f z:slideThru f (slide z)
+ src/GramLab/Morfette/Models2.hs view
@@ -0,0 +1,152 @@+module GramLab.Morfette.Models2 ( train+ , trainFun+ , predict + , predictPipeline+ , toModelFun+ , mkPreprune+ , sentToExamples+ , FeatureSpec (..)+ , Row(..)+ )+where+import GramLab.Morfette.LZipper+import qualified Data.Map as Map+import Data.Map ((!))+import Data.List (sortBy,foldl',transpose)+import Data.Ord (comparing)+import Data.Dynamic+import GramLab.FeatureSet+import qualified GramLab.Perceptron.Model as M+import Data.Traversable (forM)+import qualified Data.IntMap as IntMap+import Data.Maybe (fromMaybe)+import Debug.Trace+import Data.Binary+import Control.Monad (liftM, liftM2)+import GramLab.Utils (uniq)+import qualified Data.Vector.Unboxed as U+import GramLab.Morfette.BinaryInstances++data Row t a = Row { input :: !t, output :: ![a] } + deriving (Eq,Ord,Show,Read)+++data FeatureSpec t a = + FS { label :: Row t a -> a+ , features :: LZipper (Row t a) (Row t a) (Row t a) -> [Feature String Double] + , preprune :: ProbDist a -> ProbDist a+ , check :: LZipper (Row t a) (Row t a) (Row t a) -> a -> Bool + , trainSettings :: M.TrainSettings }+ + +instance (Binary t, Binary a) => Binary (Row t a) where+ put t = put (input t) >> put (output t)+ get = liftM2 Row get get+ ++type ProbDist a = [(a,Double)]++type Model t a = LZipper (Row t a) (Row t a) (Row t a) -> ProbDist a++beamSearch :: + Int + -- beam size+ -> [Model t a] + -- models for each output column+ -> ProbDist (LZipper (Row t a) (Row t a) (Row t a)) + -- prob dist over sequence of "tokens in context" (as lzippers)+ -> ProbDist [Row t a] + -- prob dist over sequences of "tokens"+beamSearch n ms pzs =+ let apply pzs model = + prune n + [ (modify (\t -> t { output = output t ++ [label] }) z -- add label to output+ , p0 * p -- multiply probability in+ ) + | (z, p0) <- pzs -- for each sequence (lzipper)+ , (label, p) <- model z -- get label and prob by applying+ -- model. + ]+ in if any (atEnd . fst) pzs + -- of any lzipper at end then return tokens+ then flip map pzs $ \(z,p) -> (reverse (left z), p)+ else + -- otherwise apply both classifiers in turn in the lzipper seq,+ -- prune, adjust probs+ beamSearch n ms . map (\(z,p) -> (slide z,p)) $! (foldl' apply pzs ms)++-- pruning and prepruning++prune :: Int -> ProbDist a -> ProbDist a+prune n = take n . sortBy (flip (comparing snd))+collectUntil cond f z [] = []+collectUntil cond f z (x:xs) = let z' = (f $! x) $! z + in if cond x z' then []+ else x: collectUntil cond f z' xs+mkPreprune th = collectUntil (\x z -> th > snd x / z) ((+) . snd) 0++trainFun :: (Ord a, Show a) => [FeatureSpec t a] -> [[Row t a]] -> [Model t a]+trainFun fspecs sents = + let ms = train fspecs sents+ in (zipWith toModelFun fspecs ms) + +train :: (Ord a,Show a) => + [FeatureSpec t a] + -> [[Row t a]] + -> [M.Model a Int String Double]+train fspecs sents = + flip map fspecs+ $ \fs -> let yxs = concatMap (sentToExamples fs) $ sents+ ys = uniq . map fst $ yxs+ zs = concat [ take (length s) + . iterate slide + . fromList+ $ s + | s <- sents ]+ yss = [ [ y | y <- ys , check fs z y ] + | z <- zs ]+ in M.train (trainSettings fs) yss yxs++toModelFun :: (Ord a, Show a) => + FeatureSpec t a + -> (M.Model a Int String Double) + -> Model t a+toModelFun fs m = + let ys = Map.keys . M.classMap . M.modelData $ m+ in+ \ z -> case filter (check fs z) ys of+ [] -> error "GramLab.Morfette.Models.toModelFun: unexpected []"+ y:ys' -> + preprune fs + . M.distribution m (y:ys')+ . features fs + $ z + +predict :: Int -> Int -> [Model t a] -> [[Row t a]] -> [[[Row t a]]]+predict k beamSize models sents = map predictK sents+ where predictK s = transpose + . map fst + . take k+ . beamSearch beamSize models + $ [(fromList s,1)]++predictPipeline :: Int -> [Model t a] -> [[Row t a]] -> [[Row t a]]+predictPipeline beamSize models sents = map predictK sents+ where predictK s = foldl' (\s1 m -> fst . head . beamSearch beamSize [m] + $ [(fromList s1,1)]) s models+ ++sentToExamples :: FeatureSpec t a + -> [Row t a] + -> [(a,[Feature String Double])]+sentToExamples fs xs = slideThru f (fromList xs)+ where f z = + ( label fs + . fromMaybe+ (error "GramLab.Morfette.Models.sentToExample:fromMaybe")+ . focus + $ z+ , features fs z)+ +slideThru f z | atEnd z = []+slideThru f z = f z:slideThru f (slide z)
src/GramLab/Morfette/Token.hs view
@@ -1,31 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+ module GramLab.Morfette.Token ( Token , Sentence+ , Emb , tokenForm+ , tokenEmb , tokenLemma , tokenPOS , parseToken , nullToken , isNullToken + , lowercaseToken ) where+import qualified Data.Vector.Unboxed as U+import GramLab.Utils+import Data.Char+import Debug.Trace+import qualified Data.Text.Lazy as Text+import qualified Data.Text.Lazy.Read as Text -type Token = (String,Maybe String,Maybe String)-type Sentence = [Token]+type Emb = U.Vector Double -tokenForm (form,_,_) = form-tokenLemma (_,lemma,_) = lemma-tokenPOS (_,_,pos) = pos+data Token = Token { tokenForm :: String+ , tokenEmb :: Maybe Emb+ , tokenLemma :: Maybe String+ , tokenPOS :: Maybe String+ } deriving (Show, Eq)+type Sentence = [Token] +token :: String -> Maybe Emb -> Maybe String -> Maybe String -> Token+token f e l p = + Token { tokenForm = f, tokenEmb = e, tokenLemma = l, tokenPOS = p }+ +parseToken :: Text.Text -> Token parseToken line =- case words line of - form:lemma:pos:_ -> (form,Just lemma,Just pos)- [form,lemma] -> (form,Just lemma,Nothing)- [form] -> (form,Nothing,Nothing)- otherwise -> nullToken+ let str = Text.unpack+ t = + case Text.words line of + [form, embedding, lemma, pos] -> + token (str form) (Just (parseEmb embedding)) (Just $ str lemma) (Just $ str pos)+ [form, lemma, pos] -> + token (str form) Nothing (Just $ str lemma) (Just $ str pos)+ [form, embedding] -> + token (str form) (Just (parseEmb embedding)) Nothing Nothing + [form] -> + token (str form) Nothing Nothing Nothing+ [] -> + nullToken+ in U.length (maybe U.empty id (tokenEmb t)) `seq` t -nullToken = ("",Nothing,Nothing)-isNullToken ("",Nothing,Nothing) = True-isNullToken _ = False+nullToken = token "" Nothing Nothing Nothing +isNullToken t = t == nullToken +parseEmb :: Text.Text -> Emb+parseEmb = U.fromList + . map readDouble + . filter (not . Text.null)+ . Text.splitOn ","++readDouble :: Text.Text -> Double+readDouble s = + case Text.double s of+ Right (d, "") -> d+ Left e -> error $ "GramLab.Morfette.Token.readDouble: " ++ show e+ _ -> error $ "GramLab.Morfette.Token.readDouble: parse error"++lowercaseToken :: Token -> Token+lowercaseToken t = token (lowercase (tokenForm t)) + (tokenEmb t) + (fmap lowercase (tokenLemma t)) + (fmap lowercase (tokenPOS t))+ where lowercase = map toLower+
src/GramLab/Morfette/Utils.hs view
@@ -1,6 +1,9 @@ module GramLab.Morfette.Utils ( train , predict , Flag(..)+ , Input (..)+ , Output (..)+ , ROW , morfette ) where@@ -10,8 +13,8 @@ import System.IO.UTF8 hiding (getContents,print,putStr,putStrLn) import qualified System.IO.UTF8 as UTF8 import GramLab.Commands-import qualified GramLab.Morfette.Models as Models-import GramLab.Morfette.Models (Smth(..))+import qualified GramLab.Morfette.Models2 as Models+import GramLab.Morfette.Models2 (Row(..)) import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.IntMap as IntMap@@ -31,11 +34,14 @@ import GramLab.Morfette.Lang.Conf import Data.Binary import qualified Data.ByteString.Lazy as B+import qualified Data.Text.Lazy as Text+import qualified Data.Text.Lazy.IO as Text import qualified GramLab.Morfette.Config as C import GramLab.Morfette.Evaluation import GramLab.Morfette.Settings.Defaults import GramLab.Intern (Table(..),intern,initial,runState,evalState) import GramLab.FeatureSet (toFeatureSet,FeatureSet)+import GramLab.Data.Diff.EditTree (EditTree) import qualified Paths_morfette import Data.Version (Version(..)) import Debug.Trace@@ -60,6 +66,24 @@ | ModelId String deriving Eq +data Input = Input { inputForm :: !String, inputEmb :: !(Maybe Emb) }+ deriving (Eq, Ord, Show)+ +data Output = ET !(EditTree String Char) | POS !String + deriving (Eq, Ord, Show)++instance Binary Output where+ put (ET et) = put False >> put et+ put (POS pos) = put True >> put pos+ get = do+ tag <- get+ case tag of+ False -> liftM ET get+ True -> liftM POS get++type ROW = Row Input Output+type FEATSPEC = Models.FeatureSpec Input Output+ morfette fs fspecs = defaultMain (commands fs fspecs) "Usage: morfette command [OPTION...] [ARG...]" commands fs fspecs = [@@ -142,7 +166,7 @@ when True $ do mwes <- loadMwes (mweFile modelprefix) lex <- readConf (confFile modelprefix)- txt <- getContents+ txt <- Text.getContents let models = zipWith Models.toModelFun (map ($lex) fspecs) ms defaultBeamSize = 3 n = case [f | BeamSize f <- flags ] @@ -174,9 +198,9 @@ defaultGaussianPrior = 1 -extractFeatures :: (Ord a,Binary a,Show a) =>- (Token -> Models.Tok a, t)- -> [Conf -> Models.FeatureSpec a]+extractFeatures :: + (Token -> ROW, t)+ -> [Conf -> FEATSPEC] -> [Flag] -> [FilePath] -> IO ()@@ -194,7 +218,7 @@ [] -> fspos lex other -> error $ "GramLab.Morfette.Utils.extractFeatures: " ++ "invalid option value: " ++ show other- toks <- fmap (map parseToken . lines) getContents+ toks <- fmap (map parseToken . Text.lines) Text.getContents let ws = filter (not . null) . map tokenForm $ toks (xm,ym,xys) = convertFeatures . map swap@@ -230,15 +254,15 @@ in (xm,ym,zip xs' ys') -train :: (Ord a, Show a, Binary a) =>- (Token -> Models.Tok a, t)- -> [Conf -> Models.FeatureSpec a]+train :: + (Token -> ROW, t)+ -> [Conf -> FEATSPEC] -> [Flag] -> [FilePath] -> IO () train (prepr,_) fspecs flags [dat,modeldir] = do- toks <- fmap (map parseToken . lines) (readFile dat)- let tokSet = Set.fromList [ s | t@(s,_,_) <- toks ]+ toks <- fmap (map parseToken . Text.lines) (Text.readFile dat)+ let tokSet = Set.fromList [ tokenForm t | t <- toks ] dict <- getDict flags Nothing clusters <- getClusters flags let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f }@@ -273,17 +297,19 @@ error $ "GramLab.Morfette.Utils.train: " ++ "Incorrect arguments to command train." -toksToSentences :: (Token -> Models.Tok a) -> [Token] -> [[Models.Tok a]]+toksToSentences :: (Token -> ROW) -> [Token] -> [[ROW]] toksToSentences f toks = map (map f) $ splitWith isNullToken toks -toksToForms :: [Token] -> [[Models.Tok a]]-toksToForms toks = map (map (\ (f,_,_) ->[Str f])) - . splitWith isNullToken - $ toks--parseSents :: String -> [[Models.Tok a]]-parseSents = splitWith null . map (map Str) . map words . lines-+-- Transform list of tokens to list of sentences, where each sentence is a list of ROWs +-- (with empty output fields)+toksToForms :: [Token] -> [[ROW]]+toksToForms toks = + [ [ Row { input = Input { inputForm = tokenForm tok ,+ inputEmb = tokenEmb tok }+ , output = [] } + | tok <- sent ] + | sent <- splitWith isNullToken toks ]+ getDict :: [Flag] -> Maybe (Set.Set String) -> IO Lexicon getDict flags tokSet = do case [f | DictFile f <- flags ] of@@ -296,30 +322,33 @@ [f] -> fmap parseClusterDict $ readFile f [] -> return Map.empty -getToks :: [Flag] -> [[String]] -> String -> [Token]+getToks :: [Flag] -> [[String]] -> Text.Text -> [Token] getToks flags mwes text = let f = if Tokenize `elem` flags - then concatMap (detectMwes mwes) + then map Text.pack + . concatMap (detectMwes mwes) . List.intersperse [""] . map tokenize + . map Text.unpack else id- in map parseToken . f . lines $ text+ in map parseToken . f . Text.lines $ text -+-- TODO remove these if unnecessary formatTriple (form,lemma,pos) = unwords . map (padRight ' ' 12) $ [form,lemma,pos] formatToken (f,ml,mp) = unwords [f,fromMaybe "" ml,fromMaybe "" mp] getEval flags trainf goldf testf = do let uncase = if IgnoreCase `elem` flags then- map (\(form,lemma,pos) -> (lowercase form,fmap lowercase lemma, fmap lowercase pos))+ map lowercaseToken else id ignore = case [f | IgnorePOS f <- flags ] of [] -> const False- xs -> (\(_,_,mpos) -> case mpos of- Nothing -> False - Just pos -> any (`List.isPrefixOf` pos) xs)- isPunct = if IgnorePunct `elem` flags then (\t@(form,_,_) -> - (not . isNullToken) t && all isPunctuation form) else const False+ xs -> (\t -> case tokenPOS t of+ Nothing -> False + Just pos -> any (`List.isPrefixOf` pos) xs)+ isPunct = if IgnorePunct `elem` flags + then (\t -> (not . isNullToken) t && all isPunctuation (tokenForm t)) + else const False keep tok = (not . ignore) tok && (not . isPunct) tok train <- fmap uncase (getTokens trainf) gold <- fmap uncase (getTokens goldf)@@ -332,15 +361,15 @@ , filterZip keeps gold , filterZip keeps test , fmap (filterZip keeps) baseline )- where getTokens f = fmap (map parseToken . lines) (readFile f)+ where getTokens f = fmap (map parseToken . Text.lines) (Text.readFile f) -- FIXME its breaks sentence accuracy somehow... eval flags [trainf,goldf,testf] = do (train,gold,test,baseline) <- fmap (\ (tr, g, t, b) -> (tr,toks g, toks t, fmap toks b)) (getEval flags trainf goldf testf) let seen = Set.fromList (map tokenForm train) dict <- getDict flags . Just $ seen- let isUnseen (form,_,_) = not (form `Set.member` seen)- isUnseenInDict (form,_,_) = not (lowercase form `Map.member` dict)+ let isUnseen t = not (tokenForm t `Set.member` seen)+ isUnseenInDict t = not (lowercase (tokenForm t) `Map.member` dict) isUnseenBoth x = isUnseen x && isUnseenInDict x all_acc = tokenAccuracy gold test baseline unseen_acc = tokenAccuracy (filter isUnseen gold) (filter isUnseen test) @@ -352,7 +381,7 @@ (filter isUnseenBoth test) (fmap (filter isUnseenBoth) baseline) sent_acc = sentenceAccuracy (sents gold) (sents test) (fmap sents baseline)- goldlemma g= map (lowercase . tokenLemma) g+ goldlemma g= map (fmap lowercase . tokenLemma) g uniquePOS = fromIntegral $ Set.size $ Set.fromList $ map tokenPOS gold putStrLn $ "Unseen word ratio: " ++ printf "%4.2f" (unseen_ratio::Double) putStrLn $ "Token accuracy all:\n" ++ showAccuracy all_acc
src/GramLab/Perceptron/Multiclass.hs view
@@ -71,7 +71,6 @@ {-# INLINE softmax #-}-{-# SPECIALIZE softmax :: [Float] -> [Float] #-} softmax x = let !x_max = maximum x !a = foldl' (+) 0 . map (\ !x_i -> exp $ x_i - x_max) $ x
src/GramLab/Perceptron/Vector.hs view
@@ -45,9 +45,7 @@ scale (v,y) n = (map (\(i,vi) -> (i,vi*n)) v,y) {-# INLINE dot #-}-{-# SPECIALIZE dot :: DenseVector (Int,Int) - -> ([(Int,Float)],Int)-> Float #-}-dot :: (Ix (y,i)) => DenseVector (y,i) -> ([(i,Float)],y) -> Float+dot :: (Ix (y,i), Ix i, Ix y) => DenseVector (y,i) -> ([(i,Float)],y) -> Float dot w (x,!y) = go 0 x where go !s [] = s go !s ((!i,!xi):x) = go (s + (w ! (y,i)) * xi) x@@ -64,9 +62,7 @@ in go (s + (e - (e_a * (1/c))) * xi) x {-# INLINE unsafeDot #-}-{-# SPECIALIZE unsafeDot :: DenseVector (Int,Int) - -> ([(Int,Float)],Int)-> Float #-}-unsafeDot :: (Ix (y,i)) => DenseVector (y,i) -> ([(i,Float)],y) -> Float+unsafeDot :: (Ix (y,i), Ix i, Ix y) => DenseVector (y,i) -> ([(i,Float)],y) -> Float unsafeDot w (x,!y) = go 0 x where bs = bounds w go !s [] = s
src/Lemma.hs view
@@ -3,15 +3,19 @@ import qualified Data.Map as Map import GramLab.Morfette.Features.Common import qualified GramLab.Data.Diff.EditTree as E+import GramLab.Morfette.Models2 (Row(..))+import GramLab.Morfette.Utils (ROW, Input(..), Output(..)) import Debug.Trace import Data.Maybe (fromMaybe)+ featureSpec global = FS { label = theLabel , features = theFeatures global , preprune = mkPreprune 0.3 , check = theCheck , trainSettings = lemmaTrainSettings } -theCheck z (ES s) = +theCheck :: LZipper ROW ROW ROW -> Output -> Bool+theCheck z (ET s) = let wf = prepare . getForm . fromMaybe (error "Lemma.featureSpec.check: Nothing") @@ -19,25 +23,34 @@ $ z in E.check s wf && not (null (E.apply s wf)) -theLabel (Str form:Str pos:Str lemma:_) = make form lemma-theLabel (Str _ :Str pos:ES s:_) = ES s-theLabel other = error $ "Lemma.theLabel: match failed with " ++ show other+theLabel :: ROW -> Output+theLabel r = case output r of+ [POS _, et@(ET _)] -> et+ other -> error $ "Lemma.theLabel: match failed with " ++ show other -getForm = str . head+getForm :: ROW -> String+getForm (Row { input = Input { inputForm = form } }) = form maxSuffix = 7 maxPrefix = 5 prepare = lowercase -theFeatures global tic = focusFeatures (focus tic)- where focusFeatures (Just (Str form:Str label:_)) = [ Sym $ low form, Sym $ label- , Sym $ spellingSpec form- , lexmap (low form)- , cluster form - ]- ++ prefixes maxPrefix (low form)- ++ suffixes maxSuffix (low form)+type ET = E.EditTree String Char++theFeatures :: Conf+ -> LZipper ROW ROW ROW+ -> [Feature String Double]+theFeatures global tic = focusFeatures (focus tic)+ where focusFeatures (Just (Row { input = Input { inputForm = form } + , output = (POS label:_) })) = + [ Sym $ low form, Sym $ label+ , Sym $ spellingSpec form+ , lexmap (low form)+ , cluster form + ]+ ++ prefixes maxPrefix (low form)+ ++ suffixes maxSuffix (low form) focusFeatures other = error $ "Lemma.theFeatures: " ++ show other low = lowercase lexmap w = Set $ map (show . make w . fst) $ Map.findWithDefault [] w (dictLex global)@@ -49,4 +62,4 @@ [(s,"")] -> s other -> error ("Lemma.decode: no parse: " ++ str) apply s str = E.apply s (prepare str)-make form lemma = ES $ E.make (prepare form) (prepare lemma)+make form lemma = ET $ E.make (prepare form) (prepare lemma)
src/Main.hs view
@@ -3,18 +3,34 @@ import qualified POS as P import qualified Lemma as L-import GramLab.Morfette.Models-import GramLab.Morfette.Utils (morfette)+import GramLab.Morfette.Models2+import GramLab.Morfette.Utils +import GramLab.Morfette.Token import Debug.Trace -main = morfette (prep,format) [P.featureSpec,L.featureSpec]+main = morfette (prep, format) [P.featureSpec, L.featureSpec] +{- format = unlines . map (\ ([Str f,Str p, ES s]:ts) -> unwords $ [f, L.apply s . lowercase $ f, p ] ++ [ unwords [L.apply s . lowercase $ f , p ] | [Str f, Str p , ES s ] <- ts ] )+-}+format :: [[ROW]] -> String+format rss = + let one (Row { input = Input { inputForm = f }+ , output = [ POS pos, ET et ] }) = unwords [f, L.apply et . lowercase $ f, pos ] + in unlines [ unwords [ one r | r <- rs ] | rs <- rss ] -prep (f,Just l, Just p) = [Str f,Str p, L.make f l]+prep :: Token -> ROW+prep t = + Row { input = Input { inputForm = tokenForm t+ , inputEmb = tokenEmb t }+ , output = [ POS (maybe (error "Main: missing POS") id (tokenPOS t)) + , L.make (tokenForm t) (maybe (error "Main: missing lemma") id (tokenLemma t)) + ]+ }+
src/POS.hs view
@@ -2,9 +2,13 @@ where import GramLab.Morfette.Features.Common import qualified GramLab.Data.Diff.EditTree as E+import GramLab.Morfette.Utils (ROW, Input(..), Output(..))+import GramLab.Morfette.Models2 (Row(..)) import qualified Data.Map as Map import Lemma (apply)-featureSpec global = FS { label = (!!1)+import qualified Data.Vector.Unboxed as U++featureSpec global = FS { label = theLabel , features = theFeatures global , preprune = mkPreprune 0.3 , check = \_ _ -> True @@ -16,26 +20,39 @@ maxSuffix = 7 maxPrefix = 5 +type ET = E.EditTree String Char +theLabel :: ROW -> Output+theLabel (Row { output = (pos@(POS _):_) }) = pos+theLabel other = error $ "POS.theLabel failed with " ++ show other+ +theFeatures :: Conf+ -> LZipper ROW ROW ROW+ -> [Feature String Double] theFeatures global tic = let prev = getSome leftCtx (left tic)- in+ in concatMap leftFeatures prev ++ [Sym $ concat $ map getpos prev] -- concat prefix of previous poslabels ++ focusFeatures (focus tic) ++ concatMap rightFeatures (getSome rightCtx (right tic))- where leftFeatures (Just (Str form:Str label:ES script:_)) - = [ Sym $ label + where leftFeatures (Just (Row { input = Input { inputForm = form }+ , output = [POS label, ET script] })) =+ [ Sym $ label , Sym $ apply script (low form) , Sym $ low form ] leftFeatures Nothing = [Null , Null , Null]- focusFeatures (Just (Str form:_)) = [ Sym $ low form + focusFeatures (Just (Row { input = Input { inputForm = form , inputEmb = mv } } ))+ = [ Sym $ low form , Sym $ spellingSpec form , lexmap (low form) - , cluster form- ]+ , cluster form + ] ++ prefixes maxPrefix (low form) ++ suffixes maxSuffix (low form)- rightFeatures (Just (Str form:_)) = [Sym (low form),lexmap (low form)]+ ++ embedding mv + focusFeatures other = error $ "POS.theFeatures: format error"+ rightFeatures (Just (Row { input = Input { inputForm = form } })) = + [Sym (low form),lexmap (low form)] rightFeatures Nothing = [Null, Null] low = lowercase lexmap w = Set $ map snd $ Map.findWithDefault [] w (dictLex global)@@ -43,4 +60,7 @@ Nothing -> Null Just c -> Sym c getpos Nothing = ""- getpos (Just (Str form:Str label:_)) = head (splitPOS (lang global) label)+ getpos (Just (Row { output = (POS label:_) })) = head (splitPOS (lang global) label)+ embedding Nothing = []+ embedding (Just v) = [ Num n | n <- U.toList v ]+