diff --git a/morfette.cabal b/morfette.cabal --- a/morfette.cabal +++ b/morfette.cabal @@ -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 +Maintainer: Grzegorz Chrupała 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 diff --git a/src/GramLab/FeatureSet.hs b/src/GramLab/FeatureSet.hs --- a/src/GramLab/FeatureSet.hs +++ b/src/GramLab/FeatureSet.hs @@ -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) diff --git a/src/GramLab/Morfette/BinaryInstances.hs b/src/GramLab/Morfette/BinaryInstances.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Morfette/BinaryInstances.hs @@ -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 diff --git a/src/GramLab/Morfette/Evaluation.hs b/src/GramLab/Morfette/Evaluation.hs --- a/src/GramLab/Morfette/Evaluation.hs +++ b/src/GramLab/Morfette/Evaluation.hs @@ -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) diff --git a/src/GramLab/Morfette/Features/Common.hs b/src/GramLab/Morfette/Features/Common.hs --- a/src/GramLab/Morfette/Features/Common.hs +++ b/src/GramLab/Morfette/Features/Common.hs @@ -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 diff --git a/src/GramLab/Morfette/LZipper.hs b/src/GramLab/Morfette/LZipper.hs --- a/src/GramLab/Morfette/LZipper.hs +++ b/src/GramLab/Morfette/LZipper.hs @@ -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 [] diff --git a/src/GramLab/Morfette/Models.hs b/src/GramLab/Morfette/Models.hs deleted file mode 100644 --- a/src/GramLab/Morfette/Models.hs +++ /dev/null @@ -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) diff --git a/src/GramLab/Morfette/Models2.hs b/src/GramLab/Morfette/Models2.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Morfette/Models2.hs @@ -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) diff --git a/src/GramLab/Morfette/Token.hs b/src/GramLab/Morfette/Token.hs --- a/src/GramLab/Morfette/Token.hs +++ b/src/GramLab/Morfette/Token.hs @@ -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 + diff --git a/src/GramLab/Morfette/Utils.hs b/src/GramLab/Morfette/Utils.hs --- a/src/GramLab/Morfette/Utils.hs +++ b/src/GramLab/Morfette/Utils.hs @@ -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 diff --git a/src/GramLab/Perceptron/Multiclass.hs b/src/GramLab/Perceptron/Multiclass.hs --- a/src/GramLab/Perceptron/Multiclass.hs +++ b/src/GramLab/Perceptron/Multiclass.hs @@ -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 diff --git a/src/GramLab/Perceptron/Vector.hs b/src/GramLab/Perceptron/Vector.hs --- a/src/GramLab/Perceptron/Vector.hs +++ b/src/GramLab/Perceptron/Vector.hs @@ -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 diff --git a/src/Lemma.hs b/src/Lemma.hs --- a/src/Lemma.hs +++ b/src/Lemma.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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)) + ] + } + diff --git a/src/POS.hs b/src/POS.hs --- a/src/POS.hs +++ b/src/POS.hs @@ -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 ] +