morfette 0.2 → 0.3
raw patch · 12 files changed
+207/−99 lines, 12 files
Files
- GramLab/Morfette/Lang/Conf.hs +30/−32
- GramLab/Morfette/Models.hs +2/−1
- GramLab/Morfette/Utils.hs +87/−10
- GramLab/Perceptron/IntModel.hs +9/−9
- GramLab/Perceptron/Model.hs +9/−2
- GramLab/Perceptron/Multiclass.hs +35/−24
- GramLab/Perceptron/Vector.hs +13/−15
- INSTALL +13/−0
- Lemma.hs +1/−1
- Main.hs +3/−1
- POS.hs +1/−1
- morfette.cabal +4/−3
GramLab/Morfette/Lang/Conf.hs view
@@ -5,32 +5,32 @@ , emptyLexicon , saveConf , readConf- , toksToLexicon , parseLexicon , splitPOS ) where import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Binary hiding (decode) import qualified Data.Binary as Binary (decode) import qualified Data.ByteString.Lazy as BS import Data.Maybe (catMaybes) import GramLab.Utils (padRight,splitWith,splitInto,lowercase) import GramLab.Morfette.Token-+import Debug.Trace+import qualified Control.Monad.State as S+ type Lang = String-type Lexicon = Map.Map String [(String, String, Double)]+type Lexicon = Map.Map String [(String, String)] data Conf = Conf { dictLex :: Lexicon- , trainLex :: Lexicon , lang :: Lang } deriving (Eq) instance Binary Conf where- put (Conf x y z) = put x >> put y >> put z+ put (Conf x y) = put x >> put y get = do x <- get y <- get- z <- get- return (Conf x y z)+ return (Conf x y) emptyLexicon = Map.empty @@ -46,39 +46,37 @@ txt <- BS.readFile path return (Binary.decode txt) -toksToLexicon :: [Token] -> Lexicon-toksToLexicon xs = - Map.map - (\ys -> let ms = Map.fromListWith (+) - . map (\x -> (x,1))- $ ys- size = fromIntegral $ Map.size ms- in map (\((lemma,pos),count) - -> (lemma,pos,fromIntegral count/size))- . Map.toList - $ ms)- . foldr (\(form,lemma,pos) m -> - Map.insertWith (++) form [(lemma,pos)] m) Map.empty - . catMaybes $ flip map xs $ \x ->- case x of- (form, Just lemma, Just pos) -> - Just (lowercase form, lowercase lemma,lowercase pos)- _ -> Nothing+parseLexicon :: Maybe (Set.Set String) -> String -> Lexicon +parseLexicon toks = + Map.fromListWith (++)+ . flip S.evalState Map.empty + . mapM (\(f,(l,p)) -> do+ f' <- atomize f+ l' <- atomize l+ p' <- atomize p+ return (f',[(l',p')]))+ . maybe id (\d -> filter (\(w,_) -> w `Set.member`d)) toks+ . concatMap parseEntry + . lines -parseLexicon text = Map.fromList . map parseEntry . lines $ text- -parseEntry :: String -> (String, [(String, String, Double)])+parseEntry :: String -> [(String,(String, String))] parseEntry line = let (form:pairs) = words line - len = fromIntegral $ length pairs- in (form,(map (\ [lemma,pos] - -> (lowercase lemma,lowercase pos,1/len)) - (splitInto 2 pairs)))+ in [ lemma == lemma && pos == pos `seq` (form,(lemma,lowercase pos))+ | [lemma,pos] <- splitInto 2 $ pairs ] + splitPOS :: Lang -> String -> [String] splitPOS "tr" = splitWith (=='+') splitPOS "pl" = splitWith (==':') splitPOS "cy" = splitWith (=='-') splitPOS "ga" = splitWith (=='-') splitPOS _ = map return++atomize str = do+ d <- S.get+ case Map.lookup str d of+ Nothing -> do S.put (Map.insert str str d)+ return str+ Just str' -> return str'
GramLab/Morfette/Models.hs view
@@ -4,6 +4,7 @@ , predictPipeline , toModelFun , mkPreprune+ , sentToExamples , FeatureSpec (..) , Smth(..) , Tok@@ -81,7 +82,7 @@ let ms = train fspecs sents in (zipWith toModelFun fspecs ms) -train :: (Ord a) => +train :: (Ord a,Show a) => [FeatureSpec a] -> [[Tok a]] -> [M.Model (Label a) Int String Double]
GramLab/Morfette/Utils.hs view
@@ -5,7 +5,8 @@ , morfette ) where-import Prelude hiding (print,getContents,putStrLn,putStr,writeFile,readFile)+import Prelude hiding (print,getContents,putStrLn,putStr+ ,writeFile,readFile) import System.IO (stderr,stdout) import System.IO.UTF8 import GramLab.Commands@@ -13,8 +14,10 @@ import GramLab.Morfette.Models (Smth(..)) import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Data.IntMap as IntMap import Control.Monad hiding (join)-import GramLab.Utils (padRight,splitWith,splitInto,join,tokenize,lowercase)+import GramLab.Utils (padRight,splitWith,splitOn+ ,splitInto,join,tokenize,lowercase) import qualified GramLab.Perceptron.Model as M import GramLab.Morfette.Token import GramLab.Morfette.LZipper@@ -32,6 +35,9 @@ 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 Debug.Trace data Flag = ModelPrefix String | Eval@@ -48,6 +54,7 @@ | EntropyTh Double | IterPOS Int | IterLemma Int+ | ModelId String deriving Eq morfette fs fspecs = defaultMain (commands fs fspecs) "Usage: morfette command [OPTION...] [ARG...]"@@ -69,6 +76,16 @@ "iterations for Lemma model" ] [ "TRAIN-FILE", "MODEL-DIR" ])+ , ("extract-features", CommandSpec (extractFeatures fs fspecs)+ "extract features"+ [ Option [] ["dict-file"] + (ReqArg DictFile "PATH")+ "path to optional dictionary"+ , Option [] ["model-id"]+ (ReqArg ModelId "pos|lemma")+ "model id (`pos' or `lemma')"+ ]+ [ "MODEL-DIR"]) , ("predict" , CommandSpec (predict fs fspecs) "predict postags and lemmas using saved model data"@@ -127,14 +144,74 @@ confFile dir = dir </> "conf.model" mweFile dir = dir </> "mwe.model" modelFile dir = dir </> "models.model"+classMapFile dir = dir </> "classmap.model"+featMapFile dir = dir </> "featmap.model"+ defaultGaussianPrior = 1 +extractFeatures :: (Ord a,Binary a,Show a) =>+ (Token -> Models.Tok a, t)+ -> [Conf -> Models.FeatureSpec a]+ -> [Flag]+ -> [FilePath]+ -> IO ()+extractFeatures (prepr,fmt) [fspos,fslem] flags [modeldir] = do+ dict <- getDict flags Nothing+ -- dict == dict `seq` return ()+ let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f }+ lex = Conf { dictLex = dict+ , lang = langConf }+ fs = case [f | ModelId f <- flags ] of+ ["pos"] -> fspos lex+ ["lemma"] -> fslem lex+ [] -> fspos lex+ other -> error $ "GramLab.Morfette.Utils.extractFeatures: " + ++ "invalid option value: " ++ show other+ toks <- fmap (map parseToken . lines) getContents+ let ws = filter (not . null) . map tokenForm $ toks+ (xm,ym,xys) = convertFeatures+ . map swap+ . concatMap (Models.sentToExamples fs)+ . toksToSentences prepr + $ toks + putStr . unlines + . map format+ . zip ws+ $ xys+ B.writeFile (classMapFile modeldir) . encode $ ym+ B.writeFile (featMapFile modeldir) . encode $ xm++format :: (String,(IntMap.IntMap Double,Int)) -> String+format (w,(x,y)) = unwords (w:show y : [ show i ++ ":" ++ show n + | (i,n) <- IntMap.toList x ])+parse :: String -> (String,(IntMap.IntMap Double,Int))+parse s = case words s of+ (w:y:x) -> (w,( IntMap.fromList [ (read i,read xi) + | ixi <- x+ , let [i,xi] = splitOn ':' ixi+ ]+ , read y ))+swap (y,x) = (x,y)++convertFeatures xys = + let (xs,ys) = unzip xys+ (xs',xm) = flip runState initial . mapM toFeatureSet $ xs+ (ys',ym) = flip runState initial . mapM intern $ ys+ in (xm,ym,zip xs' ys')+++train :: (Ord a, Show a, Binary a) =>+ (Token -> Models.Tok a, t)+ -> [Conf -> Models.FeatureSpec a]+ -> [Flag]+ -> [FilePath]+ -> IO () train (prepr,_) fspecs flags [dat,modeldir] = do toks <- fmap (map parseToken . lines) (readFile dat)- dict <- getDict flags + let tokSet = Set.fromList [ s | t@(s,_,_) <- toks ]+ dict <- getDict flags $ Just tokSet let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f } lex = Conf { dictLex = dict- , trainLex = toksToLexicon toks , lang = langConf } mwes = mweSet toks g = case [f | EntropyTh f <- flags ] of @@ -172,12 +249,12 @@ parseSents :: String -> [[Models.Tok a]] parseSents = splitWith null . map (map Str) . map words . lines -getDict :: [Flag] -> IO Lexicon-getDict flags = do+getDict :: [Flag] -> Maybe (Set.Set String) -> IO Lexicon+getDict flags tokSet = do case [f | DictFile f <- flags ] of [f] -> do - text <- readFile f- return (parseLexicon text)+ d <- fmap (parseLexicon tokSet) $ readFile f+ return d [] -> return emptyLexicon getToks :: [Flag] -> [[String]] -> String -> [Token]@@ -220,10 +297,10 @@ -- FIXME its breaks sentence accuracy somehow... eval flags [trainf,goldf,testf] = do- dict <- getDict flags (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)- isUnseen (form,_,_) = not (form `Set.member` seen)+ dict <- getDict flags . Just $ seen+ let isUnseen (form,_,_) = not (form `Set.member` seen) isUnseenInDict (form,_,_) = not (lowercase form `Map.member` dict) isUnseenBoth x = isUnseen x && isUnseenInDict x all_acc = tokenAccuracy gold test baseline
GramLab/Perceptron/IntModel.hs view
@@ -15,7 +15,7 @@ import System.IO (stderr,hPutStrLn) import Control.Monad (ap,liftM2) import Data.Ix (inRange)-+import Data.Array.Unboxed import qualified GramLab.Perceptron.Multiclass as P @@ -33,21 +33,21 @@ , modelWeights :: P.Model } deriving (Show,Eq) -train :: TrainSettings -> [[Int]] -> [(Int,[(Int,Double)])] -> IntModel +train :: TrainSettings -> UArray (Int,Int) Bool+ -> [(Int,[(Int,Double)])] -> IntModel -- For compatibility, examples have label first, feature second train s yss examples = model- where examples' = [ (y,[ (i,realToFrac v) | (i,v) <- x ]) | (y,x) <- examples ]+ where examples' = + [ (y,[ (i,realToFrac v) | (i,v) <- x ]) | (y,x) <- examples ]+ examples'' = map swap examples' labels = map fst examples' featids = concatMap (map fst . snd) examples'- weights = P.train (occurTh s) - (entropyTh s) - (realToFrac $ rate s) + weights = examples'' == examples'' `seq` P.train (realToFrac $ rate s) (iter s) (lo,hi) yss- . map swap - $ examples' - model = IntModel { modelLabels = IntSet.fromList (map fst examples')+ $ examples'' + model = IntModel { modelLabels = IntSet.fromList labels , modelWeights = weights } (lo,hi) = ((minimum labels,minimum featids)
GramLab/Perceptron/Model.hs view
@@ -18,9 +18,11 @@ import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Map ((!))+import qualified Data.IntSet as IntSet+import Data.Array.Unboxed hiding ((!)) import Data.List (foldl') import Data.Maybe (catMaybes)-+import GramLab.Utils (uniq) import Data.Char (isAlphaNum) import GramLab.Intern import GramLab.Data.Assoc@@ -55,8 +57,13 @@ , classMap = cm , inverseClassMap = invertMap cm }}- where m = I.train p (map (map (cm !)) yss) samples+ where m = I.train p yss' samples (ys,xs) = unzip examples+ yss' = accumArray (flip const) False ((0,lo),(length yss-1,hi))+ . concatMap (\(i,js) -> [ ((i,cm!j),True) | j <- js ])+ $ zip [0..] yss+ (lo,hi) = (minimum yset,maximum yset)+ yset = IntSet.toList . IntSet.fromList $ ys' (ys',T _ cm) = flip runState initial $ mapM intern ys (featsets,fm) = runState (mapM toFeatureSet xs) initial samples = zipWith (\l fs -> (l,IntMap.toList fs))
GramLab/Perceptron/Multiclass.hs view
@@ -20,8 +20,10 @@ import Prelude hiding (sum,product) import qualified Data.Binary as B import qualified Data.Map as Map-import qualified Data.Set as Set import Data.Map ((!))+import qualified Data.Set as Set+import qualified Data.IntSet as IntSet+import Data.Bits import Data.Maybe (isJust,fromMaybe) import GramLab.Utils (uniq) import Text.Printf (printf)@@ -57,14 +59,13 @@ decode (MC w) ys x = snd . maximum $ [ (w`dot`phi x y,y) | y <- ys ] -{-# INLINE decode_ #-}-decode_ :: (STRef s Int, DenseVectorST s (Y,I), DenseVectorST s (Y,I)) +{-# INLINE decode' #-}+decode' :: (Float, DenseVector (Y,I), DenseVector (Y,I)) -> [Y] -> X- -> ST s Y-decode_ w ys x = fmap (snd . maximum) - $ mapM (\y -> do { r <- w`dot_`phi x y ; return (r,y) } )- $ ys+ -> Y+decode' w ys x = snd . maximum + $ [ (w`dot'`phi x y,y) | y <- ys ] {-# INLINE softmax #-}@@ -82,14 +83,17 @@ in reverse . map swap . sort $ zip (softmax fxs) ys iter :: Float- -> [[Y]]+ -> A.UArray (Int,Int) Bool -> [(X, Y)] -> (STRef s Int, DenseVectorST s (Y,I), DenseVectorST s (Y,I)) -> ST s () iter rate yss ss (c,params,params_a) = do- for_ (zip yss ss) $ \ (ys',(x,y)) -> do+ let ((_,lo),(_,hi)) = A.bounds yss+ ys = [lo..hi]+ for_ (zip [0..] ss) $ \ (i,(x,y)) -> do params' <- unsafeFreeze params- let y'= decode (MC params') ys' x+ let ys' = [ y | y <- ys , yss A.! (i,y) ] + y'= decode (MC params') ys' x phi_xy = phi x y phi_xy' = phi x y' when (y' /= y) $ do @@ -100,31 +104,38 @@ params_a `plus_` (phi_xy' `scale` (rate * (-1) * fromIntegral c')) modifySTRef c (+1) -train :: Int - -> Double- -> Float+train :: Float -> Int -> ((Y,I), (Y,I))- -> [[Y]]+ -> A.UArray (Int,Int) Bool -> [(X, Y)] -> Model-train th1 th2 rate epochs bounds yss xys = MC m+train rate epochs bounds yss xys = MC m where m = runSTUArray $ do trace (show bounds) () `seq` return () params <- newArray bounds 0 params_a <- newArray bounds 0 c <- newSTRef 1+ let ixys = zip [0..] xys+ ((_,lo),(_,hi)) = A.bounds yss+ ys = [lo..hi] for_ [1..epochs] $ - \i -> do iter rate yss xys (c,params,params_a)- corr <- fmap sum - . flip mapM (zip yss xys)- $ \(ys,(x,y)) -> do - y'<- decode_ (c,params,params_a) ys x - return . fromEnum $ y' /= y- let err :: Double- err = fromIntegral corr / + \i -> do iter rate yss xys (c,params,params_a)+ c' <- readSTRef c+ params' <- unsafeFreeze params+ params_a' <- unsafeFreeze params_a+ let w = (fromIntegral c',params',params_a')+ corr = sum + . map (\(j,(x,y)) -> + let s = [ y | y <- ys + , yss A.!(j,y)]+ in fromEnum + $ y /= decode' w s x)+ $ ixys+ let err :: Double+ err = fromIntegral corr / fromIntegral (length xys)- runLogger + runLogger $ hPutStrLn stderr $ printf "Iteration %d: error: %2.4f" i err finalParams (c, params, params_a)
GramLab/Perceptron/Vector.hs view
@@ -7,7 +7,7 @@ , plus_ , scale , dot - , dot_+ , dot' , unsafeDot ) where@@ -33,9 +33,9 @@ plus_ :: (Show (y,i),Ix (y,i)) => DenseVectorST s (y,i) -> SparseVector y i -> ST s ()-plus_ w (v,y) = do- for_ v $ \(i,vi) -> do- wi <- readArray w (y,i) +plus_ w (v,!y) = do+ for_ v $ \(!i,!vi) -> do+ !wi <- readArray w (y,i) writeArray w (y,i) (wi + vi) {-# SPECIALIZE scale :: SparseVector Int Int @@ -52,18 +52,16 @@ where go !s [] = s go !s ((!i,!xi):x) = go (s + (w ! (y,i)) * xi) x -{-# INLINE dot_ #-}-dot_ :: (STRef s Int, DenseVectorST s (Int,Int), DenseVectorST s (Int,Int)) +{-# INLINE dot' #-}+dot' :: (Float,DenseVector (Int,Int),DenseVector (Int,Int)) -> ([(Int,Float)],Int)- -> ST s Float-dot_ (c,params,params_a) (x,y) = do- c' <- fmap fromIntegral (readSTRef c)- let go !s [] = return s- go !s ((i,xi):x) = do- e <- readArray params (y,i)- e_a <- readArray params_a (y,i)- go (s + (e - (e_a * (1/c'))) * xi) x- go 0 x+ -> Float+dot' (!c,params,params_a) (x,!y) = go 0 x+ where go !s [] = s+ go !s ((!i,!xi):x) = + let e = params ! (y,i)+ e_a = params_a ! (y,i)+ in go (s + (e - (e_a * (1/c))) * xi) x {-# INLINE unsafeDot #-} {-# SPECIALIZE unsafeDot :: DenseVector (Int,Int)
+ INSTALL view
@@ -0,0 +1,13 @@+=BUILDING INSTRUCTIONS=++You will need the GHC compiler <http://www.haskell.org/ghc/>. Morfette+depends on the following additional Haskell libraries:+ * utf8-string: http://hackage.haskell.org/package/utf8-string+ * binary: http://hackage.haskell.org/package/binary++Once you have GHC and the libraries, the rest is straightforward. +Unpack morfette and run the following commands:++ > runghc Setup configure --prefix=path/to/install-dir + > runghc Setup build+ > runghc Setup install
Lemma.hs view
@@ -33,7 +33,7 @@ ++ suffixes maxSuffix (low form) focusFeatures other = error $ "Lemma.theFeatures: " ++ show other low = lowercase- lexmap w = Set $ map (\(l,p,c) -> show $ make w l) $ Map.findWithDefault [] w (dictLex global)+ lexmap w = Set $ map (show . make w . fst) $ Map.findWithDefault [] w (dictLex global) decode str = case reads str of [(s,"")] -> s
Main.hs view
@@ -9,6 +9,8 @@ main = morfette (prep,format) [P.featureSpec,L.featureSpec] -format toks = unlines . map (\ [Str f,Str p,ES s] -> unwords [f,L.apply s (lowercase f),p]) $ toks+format = unlines . map (\ [Str f,Str p,ES s] -> + unwords [f,L.apply s . lowercase $ f,p]) + prep (f,Just l, Just p) = [Str f,Str p, L.make f l]
POS.hs view
@@ -36,6 +36,6 @@ rightFeatures (Just (Str form:_)) = [Sym (low form),lexmap (low form)] rightFeatures Nothing = [Null, Null] low = lowercase- lexmap w = Set $ map (\(l,p,c) -> p) $ Map.findWithDefault [] w (dictLex global)+ lexmap w = Set $ map snd $ Map.findWithDefault [] w (dictLex global) getpos Nothing = "" getpos (Just (Str form:Str label:_)) = head (splitPOS (lang global) label)
morfette.cabal view
@@ -1,6 +1,7 @@ Name: morfette-Version: 0.2-Synopsis: Morfette: tool for supervised learning of morphology+Version: 0.3+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 morphology. Given a corpus of sentences annotated with lemmas and morphological labels, and optionally a lexicon, morfette @@ -11,7 +12,7 @@ Maintainer: Grzegorz Chrupała <gchrupala@lsv.uni-saarland.de> build-type: Simple category: Natural Language Processing-Extra-source-files: README+Extra-source-files: README, INSTALL Executable: morfette Main-Is: Main.hs