diff --git a/GramLab/Morfette/Lang/Conf.hs b/GramLab/Morfette/Lang/Conf.hs --- a/GramLab/Morfette/Lang/Conf.hs +++ b/GramLab/Morfette/Lang/Conf.hs @@ -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' diff --git a/GramLab/Morfette/Models.hs b/GramLab/Morfette/Models.hs --- a/GramLab/Morfette/Models.hs +++ b/GramLab/Morfette/Models.hs @@ -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] diff --git a/GramLab/Morfette/Utils.hs b/GramLab/Morfette/Utils.hs --- a/GramLab/Morfette/Utils.hs +++ b/GramLab/Morfette/Utils.hs @@ -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 diff --git a/GramLab/Perceptron/IntModel.hs b/GramLab/Perceptron/IntModel.hs --- a/GramLab/Perceptron/IntModel.hs +++ b/GramLab/Perceptron/IntModel.hs @@ -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) diff --git a/GramLab/Perceptron/Model.hs b/GramLab/Perceptron/Model.hs --- a/GramLab/Perceptron/Model.hs +++ b/GramLab/Perceptron/Model.hs @@ -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)) diff --git a/GramLab/Perceptron/Multiclass.hs b/GramLab/Perceptron/Multiclass.hs --- a/GramLab/Perceptron/Multiclass.hs +++ b/GramLab/Perceptron/Multiclass.hs @@ -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) diff --git a/GramLab/Perceptron/Vector.hs b/GramLab/Perceptron/Vector.hs --- a/GramLab/Perceptron/Vector.hs +++ b/GramLab/Perceptron/Vector.hs @@ -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) diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,13 @@ +=BUILDING INSTRUCTIONS= + +You will need the GHC compiler . 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 diff --git a/Lemma.hs b/Lemma.hs --- a/Lemma.hs +++ b/Lemma.hs @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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] diff --git a/POS.hs b/POS.hs --- a/POS.hs +++ b/POS.hs @@ -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) diff --git a/morfette.cabal b/morfette.cabal --- a/morfette.cabal +++ b/morfette.cabal @@ -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 build-type: Simple category: Natural Language Processing -Extra-source-files: README +Extra-source-files: README, INSTALL Executable: morfette Main-Is: Main.hs