diff --git a/GramLab/Binomial.hs b/GramLab/Binomial.hs new file mode 100644 --- /dev/null +++ b/GramLab/Binomial.hs @@ -0,0 +1,60 @@ +module GramLab.Binomial (binomialTest) +where +import qualified Data.List as List +import Debug.Trace +import Test.QuickCheck +-- | Calculates the two-sided p-value for n trials and c successes with probability 0.5 +binomialTest n c | c > n = error "GramLab.Binomial.binomialTest c greater than n" +binomialTest n c = 1 `min` (2 * if c >= n `div` 2 + then binomialTestGreater n 0.5 c + else binomialTestGreater n 0.5 (n-c)) +-- | Calculates the one-sided p-value for n trials and c successes with probability p +binomialTestGreater :: Integer -> Double -> Integer -> Double +binomialTestGreater n p c = sum $ fmap (\(pr1,pr2,pw1,pw2) -> fromIntegral (pr1 `div` pr2) * pw1 * pw2) $ + List.zip4 (products1 n c) + (products2 n c) + (powers1 p n c) + (powers2 p n c) +divv a b | trace (show (a,b)) False = undefined +divv a b = a `div` b + +-- | +spec_products1 n c = fmap (\x -> product [x+1..n]) [c..n] +--products1 :: Int -> Int -> [Int] +products1 n c | c == n = [1] + | c+1 == n = [n,1] -- + | otherwise = let x:xs = products1 n (c+1) in ((1+c)*x):x:xs + +-- | +spec_products2 n c = fmap (\x -> product [1..n-x]) [c..n] +--products2 :: Int -> Int -> [Int] +products2 n c | c == n = [1] + | otherwise = let x:xs = products2 n (c+1) in ((n-c)*x):x:xs + +-- | +spec_powers1 p n c = fmap (p^) [c..n] +--powers1 :: Double -> Int -> Int -> [Double] +powers1 p n c = reverse (powers1' [p^c] p n c) +powers1' (x:xs) p n c | n == c = x:xs + | otherwise = powers1' ((p*x):x:xs) p n (c+1) + +-- | +spec_powers2 p n c = fmap (\x -> (1-p)^(n-x)) [c..n] +--powers2 :: Double -> Int -> Int -> [Double] +powers2 p n c | n == c = [1] + | otherwise = let x:xs = powers2 p n (c+1) in (1-p)*x:x:xs + +prop_products1 :: (Integer,Integer) -> Property +prop_products1 (n,c) = n > 0 && c > 0 && n >= c ==> spec_products1 n c == products1 n c + +prop_products2 :: (Integer,Integer) -> Property +prop_products2 (n,c) = n > 0 && c > 0 && n >= c ==> spec_products2 n c == products2 n c + +epsilon = 1.0e-15 + +prop_powers1 :: (Double,Integer,Integer) -> Property +prop_powers1 (p,n,c) = p >= 0 && p <= 1 && n > 0 && c > 0 && n >= c + ==> all ( abs (a-b)) (spec_powers1 p n c) (powers1 p n c)) +prop_powers2 :: (Double,Integer,Integer) -> Property +prop_powers2 (p,n,c) = p >= 0 && p <= 1 && n > 0 && c > 0 && n >= c + ==> all ( abs (a-b)) (spec_powers2 p n c) (powers2 p n c)) diff --git a/GramLab/Commands.hs b/GramLab/Commands.hs new file mode 100644 --- /dev/null +++ b/GramLab/Commands.hs @@ -0,0 +1,54 @@ +module GramLab.Commands ( Command + , CommandName + , Help + , CommandSpec (..) + , module System.Console.GetOpt + , defaultMain +) +where +import Text.PrettyPrint(renderStyle,render,nest,vcat,hsep,style,Mode(..),mode,text,(<>),($$),($+$),(<+>)) +import System.Console.GetOpt +import System +import System.IO (stderr) +import System.IO.UTF8 (hPutStr) +import qualified Data.List as List + + +type Command a = ([a] -> [String] -> IO ()) +type CLArgName = String +type CommandName = String +type Help = String +data CommandSpec a = CommandSpec (Command a) + Help + [OptDescr a] + [CLArgName] + +defaultMain commands header = do + args <- getArgs + let theUsage = usage commands header + case args of + [] -> theUsage [] + command:opts -> case List.lookup command commands of + Nothing -> theUsage ["Invalid command: " ++ command] + Just spec -> runCommand theUsage spec opts + +runCommand theUsage (CommandSpec command help optDesc argnames) args = + case getOpt Permute optDesc args of + (o,n,[] ) -> command o n + (_,_,errs) -> theUsage errs + + +usage commands header errs = hPutStr stderr . render + $ vcat (List.map text errs) + $$ usageMsg commands header + +usageMsg commands header = + text header + $+$ (vcat (List.map commandUsage commands)) + +commandUsage (name , CommandSpec command help optionDesc args) = + text name <> text ":" + $$ (nest 10 (text help)) + $$ (text name <+> text "[OPTION...]" <+> hsep (map text args)) + <+> (nest 10 (text $ usageInfo "" optionDesc)) + diff --git a/GramLab/Data/Assoc.hs b/GramLab/Data/Assoc.hs new file mode 100644 --- /dev/null +++ b/GramLab/Data/Assoc.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module GramLab.Data.Assoc ( Assoc + , fromAssoc + ) +where + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.List as List + + + +class (Ord k) => Assoc assoc k v | assoc -> k v where + toList :: assoc -> [(k,v)] + fromList :: [(k,v)] -> assoc + fromAssoc :: (Assoc assoc2 k v) => assoc -> assoc2 + fromAssoc = fromList . toList + +instance (Ord k) => Assoc [(k,v)] k v where + toList = id + fromList = id + +instance Assoc (IntMap.IntMap v) Int v where + toList = IntMap.toAscList + fromList = IntMap.fromList + +instance (Ord k) => Assoc (Map.Map k v) k v where + toList = Map.toAscList + fromList = Map.fromList diff --git a/GramLab/Data/CommonSubstrings.hs b/GramLab/Data/CommonSubstrings.hs new file mode 100644 --- /dev/null +++ b/GramLab/Data/CommonSubstrings.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NoMonomorphismRestriction#-} +module GramLab.Data.CommonSubstrings ( lcs + , lcsFiltering + , commonSubstrings + , substrings + , toMap + , CommonSubstring + , Indices + ) + +where + +import Data.List +import qualified Data.Map as Map +import Data.Ord +import Data.Char +import qualified GramLab.Data.StringLike as S + + +type Indices = ([Int],[Int]) +commonSubstrings :: (Ord s, Ord a, S.StringLike s a) => s -> s -> Map.Map s Indices +commonSubstrings xs ys = Map.intersectionWith (,) ((toMap . substrings) xs) + ((toMap . substrings) ys) + +commonSubstringsWith equiv xs ys = [ (x,y,i_x,i_y) | (x,i_x) <- (Map.toList . toMap . substrings) xs + , (y,i_y) <- (Map.toList . toMap . substrings) ys + , x `equiv` y ] +collapseVowels [] = [] +collapseVowels [x] = [x] +collapseVowels (x:y:xs) | vowel x && vowel y = '@':collapseVowels xs + | vowel x = '@':collapseVowels (y:xs) + | otherwise = x :collapseVowels (y:xs) + where vowel x = x `elem` "ieaou" + +equiv xs ys = collapseVowels xs == collapseVowels ys + +type CommonSubstring s = (s,Indices) + +longest :: (Ord s, Ord a, S.StringLike s a) => Map.Map s Indices -> [CommonSubstring s] +longest = sortBy (flip (comparing (S.length . fst))) . Map.toList + +lcs :: (Ord a, Ord s, S.StringLike s a, Monad m) => + s -> s -> m (CommonSubstring s) +lcs = lcsFiltering (const True) +lcsFiltering :: (Ord s, Ord a, S.StringLike s a, Monad m) => + (CommonSubstring s -> Bool) + -> s + -> s + -> m (CommonSubstring s) +lcsFiltering f xs ys = case longest (Map.filterWithKey (curry f) (commonSubstrings xs ys)) of + [] -> fail "lcsFiltering: no common strings" + (x:_) -> return x + +substrings :: (Enum b, Num b,Ord a, S.StringLike s a) => s -> [(s, b)] +substrings xs = [ (S.fromString $ map fst suffix, snd . head $ suffix) + | prefix <- tail $ inits' (zip (S.toString xs) [0..]) + , suffix <- init $ tails prefix ] +inits' = reverse . map reverse . tails . reverse + +toMap :: (Ord k) => [(k,v)] -> Map.Map k [v] +toMap = foldr (\(k,v) z -> Map.insertWith (++) k [v] z) Map.empty diff --git a/GramLab/Data/Diff/EditList.hs b/GramLab/Data/Diff/EditList.hs new file mode 100644 --- /dev/null +++ b/GramLab/Data/Diff/EditList.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module GramLab.Data.Diff.EditList ( make + , apply + , check + , EditList + ) +where +import GramLab.Data.LCS.SimpleMemo (ses, check, apply, EditScript(..)) +type EditList a = EditScript a +make = ses diff --git a/GramLab/Data/Diff/EditListRev.hs b/GramLab/Data/Diff/EditListRev.hs new file mode 100644 --- /dev/null +++ b/GramLab/Data/Diff/EditListRev.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module GramLab.Data.Diff.EditListRev ( make + , apply + , check + , EditListRev(ELR) + , SES.Edit(..) + ) +where +import qualified GramLab.Data.LCS.SimpleMemo as SES +newtype EditListRev a = ELR { un :: SES.EditScript a } deriving (Eq,Ord,Show,Read) +make w w' = ELR $ SES.ses (reverse w) (reverse w') +apply s w = reverse (SES.apply (un s) (reverse w)) +check s w = SES.check (un s) (reverse w) + diff --git a/GramLab/Data/Diff/EditTree.hs b/GramLab/Data/Diff/EditTree.hs new file mode 100644 --- /dev/null +++ b/GramLab/Data/Diff/EditTree.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module GramLab.Data.Diff.EditTree ( make + , apply + , check + , split3 + , EditTree(..) + ) +where + +import GramLab.Data.CommonSubstrings +import qualified GramLab.Data.StringLike as S +import Data.Maybe (fromMaybe) +import Debug.Trace + +make = editTree + +data EditTree s a = Split !Int !Int (EditTree s a) (EditTree s a) + | Replace s s + deriving (Eq,Ord,Show,Read) +editTree w w' = case lcsi w w' of + Nothing -> Replace w w' + Just (i_w,i_w_end,i_w',i_w'_end) -> + let (w_prefix, w_root, w_suffix) = split3 w i_w i_w_end + (w'_prefix,w'_root, w'_suffix) = split3 w' i_w' i_w'_end + in Split i_w i_w_end + (editTree w_prefix w'_prefix) + (editTree w_suffix w'_suffix) + +lcsi w w' = fmap f (lcs w w') + where f (str,(i_w:_,i_w':_)) = (i_w,i_w_end,i_w',i_w'_end) + where i_w_end = S.length w - i_w - len + i_w'_end = S.length w' - i_w' - len + len = S.length str + +apply (Replace s s') w = s' +apply (Split i i_end lt rt) w = (apply lt pre) `S.append` root `S.append` (apply rt suf) + where (pre,root,suf) = split3 w i i_end + + +split3 w i i_end = let (prefix, rest) = S.splitAt i w + (suffix_r, root_r) = S.splitAt i_end (S.reverse rest) + in (prefix,(S.reverse root_r),(S.reverse suffix_r)) + + +check (Replace s s') w = s == w +check (Split i j lt rt) w = len >= i + && len >= j + && check lt w_pre + && check rt w_suf + where len = S.length w + (w_pre,w_root,w_suf) = split3 w i j + diff --git a/GramLab/Data/LCS/SimpleMemo.hs b/GramLab/Data/LCS/SimpleMemo.hs new file mode 100644 --- /dev/null +++ b/GramLab/Data/LCS/SimpleMemo.hs @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- Memoized version of Simple.hs [1] but still simple stupid and slow. +-- foldlcs lcs and ses adapted from Gauche's util.lcs module [2] +-- [1] http://urchin.earth.li/darcs/ian/lcs/Data/List/LCS/Simple.hs +{-# OPTIONS -fglasgow-exts #-} +-- [2] http://www.shiro.dreamhost.com/scheme/gauche/memo.html +module GramLab.Data.LCS.SimpleMemo ( Edit (Ins,Del) + , EditScript + , lcs + , ses + , apply + , check + ) +where + +import Control.Monad.State +import qualified Data.Map as Map +import Data.Typeable +import Prelude hiding (lookup) +import Maybe (catMaybes) +import Debug.Trace +data Edit a = Ins a Int + | Del a Int deriving (Eq,Ord,Show,Read,Typeable) +type EditScript a = [Edit a] + +-- |The 'lcs' function takes two lists and returns a list with a longest +-- common subsequence of the two. +lcs :: (Ord a, Eq a) => [a] -> [a] -> [a] +lcs xs ys = map (\(x,_,_) -> x) (snd (lcsWithPositions xs ys)) + +-- |The 'ses' function takes two lists and returns the shortest edit script +-- which would change the first list into the second +ses :: (Ord a, Eq a) => [a] -> [a] -> EditScript a +ses as bs = + reverse changes + where aOnly a ((aPos,bPos),zs) = ((aPos+1,bPos),(Del a aPos) : zs) + bOnly b ((aPos,bPos),zs) = ((aPos,bPos+1),(Ins b aPos) : zs) + both c ((aPos,bPos),zs) = ((aPos+1,bPos+1),zs) + (_,changes) = foldlcs aOnly bOnly both ((0,0),[]) as bs + +-- |The 'apply' function takes an edit script and a sequence and applies the +-- changes encoded in the script to the sequence. +-- The following holds: apply (ses xs ys) xs == ys +apply :: EditScript a -> [a] -> [a] +apply s xs = concat $ applyIns s $ applyDel s xs + +foldlcs aOnly bOnly both seed a b = + loop common seed a 0 b 0 + where fold f z xs = foldl (\z x -> f x z) z xs + (len,common) = lcsWithPositions a b + loop common seed a aPos b bPos + | null common = fold bOnly (fold aOnly seed a) b + | otherwise = + let ((e,aOff,bOff):commonTail) = common + aSkip = aOff - aPos + bSkip = bOff - bPos + (aHead,aTail) = splitAt aSkip a + (bHead,bTail) = splitAt bSkip b + in loop commonTail + (both e (fold bOnly (fold aOnly seed aHead) bHead)) + (tail aTail) + (aOff + 1) + (tail bTail) + (bOff + 1) + +type PosSpec a = (a,Int,Int) +type LCSMemoTable a = Map.Map ((Int,[a]),(Int,[a])) (Int,[PosSpec a]) + +lcsWithPositions :: (Ord a) => [a] -> [a] -> (Int,[PosSpec a]) +lcsWithPositions xs ys = evalState (lcs_memo (0,xs) (0,ys)) Map.empty + +lcs_memo :: (Ord a) => (Int,[a]) -> (Int,[a]) -> State (LCSMemoTable a) (Int,[PosSpec a]) +lcs_memo xs ys = do + d <- get + case Map.lookup (xs,ys) d of + Nothing -> do + r <- lcs' lcs_memo xs ys + modify (Map.insert (xs,ys) r) + return r + Just r -> return r + +lcs' rec (px,x:xs) (py,y:ys) + | x == y = do + (len,zs) <- rec (px+1,xs) (py+1,ys) + return (len + 1, (x,px,py):zs) + | otherwise = do + r1@(l1, _) <- rec (px, x:xs) (py+1,ys) + r2@(l2, _) <- rec (px+1,xs) (py, y:ys) + if l1 >= l2 then return r1 else return r2 +lcs' _ (_,[]) _ = return (0, []) +lcs' _ _ (_,[]) = return (0, []) + + +pos (Del _ i) = i +pos (Ins _ i) = i +isIns (Ins _ _) = True +isIns (Del _ _) = False +isInsAt j (Ins _ i) = i == j +isInsAt _ _ = False +applyDel s xs = + applyDel' 0 s' xs + where s' = filter (not . isIns) s +applyIns s xs = + applyIns' 0 s' xs + where s' = filter isIns s + +applyDel' i (e@(Del _ j):es) (x:xs) + | i == j = [] : applyDel' (i+1) es xs + | otherwise = [x] : applyDel' (i+1) (e:es) xs +applyDel' i [] xs = map (:[]) xs +applyDel' i es [] = [] + +applyIns' i es (x:xs) = (insertions ++ x) : applyIns' (i+1) es xs + where insertions = insertionsAt i es +applyIns' i es [] = [insertionsAt i es] + +insertionsAt i es = concatMap (\(Ins c j) -> if j == i then [c] else []) es + +check es xs = check' 0 es xs +--check' i es xs | trace (show (i,es,xs)) False = undefined +check' i (e@(Del c j):es) (x:xs) + | i == j = c == x && check' (i+1) es xs + | otherwise = check' (i+1) (e:es) xs +check' i (e@(Ins c j):es) (x:xs) + | i == j = check' (i+1) (dropWhile (isInsAt i) es) xs + | otherwise = check' (i+1) (e:es) xs +check' i [] xs = True +check' i (Del {}:_) [] = False +check' i (Ins {}:es) [] = check' (i+1) es [] + + + +testset = [ ("carbon","cabron"),("otreum","rirom"),("evita","pabita") + , ("abcabba","cbabac"),("caballo","lacayo"),("dijeran","decir") + , ("joroba","jodieron"),("alzheimer","heimat"),("argentina","argentaria") + , ("morir","murieron"),("ordenadores","computadoras"),("toalla","oatmeal") + ] +runtest = mapM_ print $ map (\(a,b) -> ((a,b),"=>",(apply (ses a b) a) == b)) testset + diff --git a/GramLab/Data/StringLike.hs b/GramLab/Data/StringLike.hs new file mode 100644 --- /dev/null +++ b/GramLab/Data/StringLike.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module GramLab.Data.StringLike (StringLike(..)) +where +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B +import qualified Data.List as List +import Data.Word +import Prelude hiding (length,null,tail,init,splitAt,reverse,map,foldl,foldr) +import qualified Prelude as P +import Codec.Binary.UTF8.String +class StringLike seq a | seq -> a where + toString :: seq -> [a] + fromString :: [a] -> seq + length :: seq -> Int + length = P.length . toString + null :: seq -> Bool + null = P.null . toString + tail :: seq -> seq + tail = fromString . P.tail . toString + init :: seq -> seq + init = fromString . P.init . toString + tails :: seq -> [seq] + tails = P.map fromString . List.tails . toString + inits :: seq -> [seq] + inits = P.map fromString . List.inits . toString + splitAt :: Int -> seq -> (seq,seq) + splitAt i w = let (w',w'') = P.splitAt i (toString w) in (fromString w', fromString w'') + reverse :: seq -> seq + reverse = fromString . P.reverse . toString + append :: seq -> seq -> seq + append w w' = fromString (toString w ++ toString w') + cons :: a -> seq -> seq + cons x xs = fromString $ x: toString xs + uncons :: seq -> Maybe (a,seq) + uncons xs = case toString xs of + (x:xs) -> Just (x,fromString xs) + _ -> Nothing + map :: (a -> a) -> seq -> seq + map f = fromString . map f . toString + +instance StringLike [a] a where + toString = id + fromString = id + +instance StringLike B.ByteString Char where + toString = decode . B.unpack + fromString = B.pack . encode + null = B.null + append = B.append + + +instance StringLike L.ByteString Char where + toString = decode . L.unpack + fromString = L.pack . encode + null = L.null + append = L.append diff --git a/GramLab/FeatureSet.hs b/GramLab/FeatureSet.hs new file mode 100644 --- /dev/null +++ b/GramLab/FeatureSet.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NoMonomorphismRestriction + , MultiParamTypeClasses + , FunctionalDependencies + , FlexibleContexts + , FlexibleInstances + #-} +module GramLab.FeatureSet ( Feature (..) + , FeatureSet + , toFeatureSet + ) +where +import GramLab.Intern +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.List as List +import qualified GramLab.Utils as Utils +import Data.Maybe +import Data.Ord (comparing) + +data Feature sym num = Sym sym + | Set [sym] + | Num num + | Null + deriving (Show,Read,Eq,Ord) + +class FeatureSet coll key sym num | coll -> key sym num where + toFeatureSet :: (Ord key,Ord sym,Real num) => + coll -> State (Table (key,Maybe sym)) (IntMap.IntMap num) + +instance FeatureSet [Feature sym num] Int sym num where + toFeatureSet = listToFeatureSet +instance FeatureSet [(key,Feature sym num)] key sym num where + toFeatureSet = assocListToFeatureSet +instance FeatureSet (Map.Map key (Feature sym num)) key sym num where + toFeatureSet = mapToFeatureSet + + +{-# SPECIALIZE INLINE assocListToFeatureSet :: + [(Int, Feature String Double)] + -> State (Table (Int, Maybe String)) (IntMap.IntMap Double) #-} +assocListToFeatureSet = liftM (IntMap.fromList . concat) + . mapM (uncurry realFeature) +mapToFeatureSet = assocListToFeatureSet . Map.toList +listToFeatureSet = assocListToFeatureSet . Utils.index + +{-# SPECIALIZE INLINE realFeature :: + Int + -> Feature String Double + -> 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 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/GramLab/Intern.hs b/GramLab/Intern.hs new file mode 100644 --- /dev/null +++ b/GramLab/Intern.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE NoMonomorphismRestriction#-} + +module GramLab.Intern ( Table(..) + , initial + , intern + , internMany + , unintern + , uninternMany + , maybeIntern + , maybeInternMany + , module Control.Monad.State + ) +where +import Prelude hiding (mapM) +import qualified Data.Map as Map +import Control.Monad.State hiding (mapM) +import Data.Traversable (mapM) + +data Table a = T !Int (Map.Map a Int) deriving (Eq,Read,Show) + + + +initial = (T 0 Map.empty) + +intern :: (Ord k) => k -> State (Table k) Int +intern s = do + (T i m) <- get + case Map.lookup s m of + Nothing -> do + put (T (i+1) (Map.insert s i m)) + return i + Just j -> return j + +internWith hget s = do + (T i m) <- get + case Map.lookup s m of + Nothing -> do + put (T (i+1) (Map.insert s i m)) + return i + Just j -> return j + + + +internMany = mapM intern + + +-- only read existing entries in state +maybeIntern s = do + (T i m) <- get + return $ Map.lookup s m + +maybeInternMany = mapM maybeIntern + + +unintern i = do + m <- get + return $ case Map.lookup i m of { Just x -> x } + +uninternMany = mapM unintern diff --git a/GramLab/Morfette/BinaryInstances.hs b/GramLab/Morfette/BinaryInstances.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/BinaryInstances.hs @@ -0,0 +1,28 @@ +module GramLab.Morfette.BinaryInstances +where +import GramLab.Data.Diff.EditListRev +import GramLab.Data.Diff.EditTree +import Data.Binary +import Control.Monad (liftM,liftM2,liftM3,liftM4) +instance Binary a => Binary (Edit a) where + put (Ins c i) = put (0::Word8) >> put c >> put i + put (Del c i) = put (1::Word8) >> put c >> put i + get = do + tag <- get + case tag::Word8 of + 0 -> liftM2 Ins get get + 1 -> liftM2 Del get get + +instance Binary s => Binary (EditTree s a) where + put (Replace xs ys) = put (0::Word8) >> put xs >> put ys + put (Split i j lt rt) = put (1::Word8) >> put i >> put j + >> put lt >> put rt + get = do + tag <- get + case tag::Word8 of + 0 -> liftM2 Replace get get + 1 -> liftM4 Split get get get get + +instance Binary a => Binary (EditListRev a) where + put (ELR x) = put x + get = liftM ELR get diff --git a/GramLab/Morfette/Config.hs b/GramLab/Morfette/Config.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/Config.hs @@ -0,0 +1,19 @@ +module GramLab.Morfette.Config ( Config(..) + , defaults + ) +where +import GramLab.Perceptron.Model + + +data Config = Config { lemmaConfig :: TrainSettings + , posConfig :: TrainSettings } deriving (Show,Read) + +defaults = Config { lemmaConfig = TrainSettings { iter = 50 + , rate = 0.1 + , occurTh = 40 + , entropyTh = 0.0 } + , posConfig = TrainSettings { iter = 60 + , rate = 0.1 + , occurTh = 40 + , entropyTh = 0.0 } } + diff --git a/GramLab/Morfette/Evaluation.hs b/GramLab/Morfette/Evaluation.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/Evaluation.hs @@ -0,0 +1,78 @@ +module GramLab.Morfette.Evaluation ( accuracy + , tokenAccuracy + , sentenceAccuracy + , showAccuracy + ) +where +import GramLab.Morfette.Token +import Data.Maybe +import GramLab.Utils (lowercase) +import Text.Printf +import GramLab.Binomial + + +data Accuracy = Acc { lemmaAcc :: AccBL + , posAcc :: AccBL + , jointAcc :: AccBL } + +data AccBL = AccBL { test :: [Bool] + , baseline :: Maybe [Bool] } + +data Experiment = Ex { trials :: Integer + , successes :: Integer } deriving (Show) + + +rer hi lo = ((1-lo)-(1-hi))/(1-lo) + +significance :: [Bool] -> [Bool] -> Experiment +significance test baseline = Ex { trials = fromIntegral $ countTrue $ zipWith (/=) test baseline + , successes = fromIntegral $ countTrue $ zipWith (>) test baseline } +countTrue = sum . map fromEnum +pvalue ex = binomialTest (trials ex) (successes ex) + + + +tokenAccuracy :: [Token] -> [Token] -> Maybe [Token] -> Accuracy +tokenAccuracy xs ys bl = accuracy (id,id,id) (map tokToPair xs) + (map tokToPair ys) + (fmap (map tokToPair) bl) + +sentenceAccuracy :: [[Token]] -> [[Token]] -> Maybe [[Token]] -> Accuracy +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) + + +accuracy (g,h,i) gold test mbl = Acc { lemmaAcc = AccBL (correct (g fst) test) (fmap (correct (g fst)) mbl) + , posAcc = AccBL (correct (h snd) test) (fmap (correct (h snd)) mbl) + , jointAcc = AccBL (correct (i id) test) (fmap (correct (i id)) mbl) } + where correct f ys = zipWith (\x y -> f x == f y) gold ys + + + + + +showAccuracy acc = unlines [ "Lemma acc: " ++ (showAcc . lemmaAcc) acc + , "POS acc: " ++ (showAcc . posAcc ) acc + , "Joint acc: " ++ (showAcc . jointAcc) acc ] + + +showAcc (AccBL t mbl) = case mbl of + Just bl -> let acc_bl = (length bl, countTrue bl) + acc_bl_pc = (fromIntegral (snd acc_bl)/(fromIntegral (fst acc_bl)))::Double + ex = significance t bl + in printf "%05.2f%% (%d / %d) %+.2f%%, %.2f%% RER, %d different, %d better, p-value: %g" + (acc_t_pc * 100) + (snd acc_t) + (fst acc_t) + (acc_t_pc * 100 - acc_bl_pc * 100) + (rer acc_t_pc acc_bl_pc * 100) + (trials ex) + (successes ex) + (pvalue ex) + Nothing -> printf "%.2f%% (%d / %d)" (100*acc_t_pc) (snd acc_t) (fst acc_t) + where acc_t = (length t, countTrue t) + acc_t_pc = (fromIntegral (snd acc_t)/(fromIntegral (fst acc_t))) + + diff --git a/GramLab/Morfette/Features/Common.hs b/GramLab/Morfette/Features/Common.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/Features/Common.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module GramLab.Morfette.Features.Common ( spellingSpec + , prefixes + , suffixes + , lowercase + , mapSym + , mapNum + , getSome + , module GramLab.Morfette.Models + , module GramLab.Morfette.Settings.Defaults + , module GramLab.Morfette.LZipper + , module GramLab.FeatureSet + , module GramLab.Morfette.Lang.Conf + ) + +where +import GramLab.Morfette.Token +import GramLab.Morfette.LZipper(LZipper) +import GramLab.FeatureSet(FeatureSet) +import Data.Char +import Data.List +import GramLab.FeatureSet +import GramLab.Utils (padRight) +import Data.Binary +import Control.Monad (liftM,liftM2) +import GramLab.Morfette.Settings.Defaults +import GramLab.Morfette.Models +import GramLab.Morfette.LZipper +import GramLab.FeatureSet +import GramLab.Morfette.Lang.Conf + +mapSym f (Sym s) = Sym (f s) +mapSym _ x = x +mapNum f (Num n) = Num (f n) +mapNum _ x = x + +lowercase = map toLower + +suffixes size = padRight Null size . map Sym . take size . drop 1 . reverse . tails +prefixes size = padRight Null size . map Sym . take size . drop 1 . inits +bigrams [] = [] +bigrams xs = zipWith ((. return) . (:)) xs (tail xs) +getSome size xs = take size . padRight Nothing size . map Just $ xs +spellingSpec x = map head . group . map collapse $ x + +collapse c | isAlpha c && isUpper c = 'X' + | isAlpha c && isLower c = 'x' + | isDigit c = '0' + | c == '-' = '-' + | c == '_' = '_' + | otherwise = '*' diff --git a/GramLab/Morfette/LZipper.hs b/GramLab/Morfette/LZipper.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/LZipper.hs @@ -0,0 +1,48 @@ +module GramLab.Morfette.LZipper ( LZipper + , focus + , left + , right + , reset + , fromList + , modify + , slide + , slideWith + , slideWith1 + , atEnd ) +where +import Data.Maybe +import Debug.Trace + +data LZipper a b c = LZ [a] (Maybe b) [c] deriving (Show,Eq,Ord) +left (LZ xs _ _) = xs +focus (LZ _ x _) = x +right (LZ _ _ ys) = ys + +fromList [] = LZ [] Nothing [] +fromList (x:xs) = LZ [] (Just x) xs + +modify :: (b -> c) -> LZipper a b d -> LZipper a c d +--modify f z@(LZ xs x ys) | trace (show (z,(LZ xs (fmap f x) ys))) False = undefined +modify f (LZ xs x ys) = LZ xs (fmap f x) ys + +slide :: LZipper t t c -> LZipper t c c +slide = slideWith id id + +slideWith1 :: (c -> b) -> LZipper t t c -> LZipper t b c +slideWith1 = slideWith id + +slideWith :: (t -> a) -> (c -> b) -> LZipper a t c -> LZipper a b c +slideWith f g (LZ xs Nothing []) = LZ xs Nothing [] +slideWith f g (LZ lxs (Just x) rxs) = + case rxs of + y:ys -> LZ (f x:lxs) (Just (g y)) ys + [] -> LZ (f x:lxs) Nothing [] + +atEnd = isNothing . focus + +reset (LZ [] (Just y) ys) = LZ [] (Just y) ys +reset (LZ [] Nothing []) = LZ [] Nothing [] +reset (LZ xs (Just y) ys) = LZ [] (Just z) (zs++[y]++ys) + where z:zs = reverse xs +reset (LZ xs Nothing []) = LZ [] (Just z) zs + where z:zs = reverse xs diff --git a/GramLab/Morfette/Lang/Conf.hs b/GramLab/Morfette/Lang/Conf.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/Lang/Conf.hs @@ -0,0 +1,84 @@ +module GramLab.Morfette.Lang.Conf ( Lexicon + , Conf(..) + , Lang + , makeConf + , emptyLexicon + , saveConf + , readConf + , toksToLexicon + , parseLexicon + , splitPOS + ) +where +import qualified Data.Map as Map +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 + +type Lang = String +type Lexicon = Map.Map String [(String, String, Double)] +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 + get = do + x <- get + y <- get + z <- get + return (Conf x y z) + +emptyLexicon = Map.empty + +makeConf = Conf + +saveConf :: FilePath -> Conf -> IO () + +saveConf path lex = do + BS.writeFile path (encode lex) + +readConf :: FilePath -> IO Conf +readConf path = do + 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 text = Map.fromList . map parseEntry . lines $ text + +parseEntry :: String -> (String, [(String, String, Double)]) +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))) + + +splitPOS :: Lang -> String -> [String] +splitPOS "tr" = splitWith (=='+') +splitPOS "pl" = splitWith (==':') +splitPOS "cy" = splitWith (=='-') +splitPOS "ga" = splitWith (=='-') +splitPOS _ = map return diff --git a/GramLab/Morfette/MWE.hs b/GramLab/Morfette/MWE.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/MWE.hs @@ -0,0 +1,44 @@ +module GramLab.Morfette.MWE ( detectMwes + , mweSet + , saveMwes + , loadMwes + ) +where +import GramLab.Utils (join,splitWith,lowercase) +import GramLab.Morfette.Token +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Ord (comparing) +import Data.Char +import Data.Binary +import qualified Data.ByteString.Lazy as BS + +mweSep = '_' + +mweSet :: [Token] -> [[String]] +mweSet toks = List.sortBy (flip (comparing length)) + . map fst + . filter ((> 1) . snd) + . Map.toList + . Map.fromListWith (+) + . map (\x -> (x,1)) + . map (splitWith (==mweSep)) + . filter common + . map tokenForm $ toks + where common = all (\c -> isLower c || c `elem` [mweSep,'-']) + +detectMwes :: [[String]] -> [String] -> [String] +detectMwes mwes [] = [] +detectMwes mwes (x:xs) = case List.find (`List.isPrefixOf` xs') mwes of + Nothing -> x:detectMwes mwes xs + Just mwe -> let len = length mwe + in join [mweSep] (take len (x:xs)) : drop len (x:xs) + where xs' = map lowercase (x:xs) + +saveMwes path mwes = do + BS.writeFile path (encode mwes) + +loadMwes path = do + s <- BS.readFile path + return $ decode s + diff --git a/GramLab/Morfette/Models.hs b/GramLab/Morfette/Models.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/Models.hs @@ -0,0 +1,143 @@ +module GramLab.Morfette.Models ( train + , trainFun + , predict + , predictPipeline + , toModelFun + , mkPreprune + , FeatureSpec (..) + , Smth(..) + , Tok + ) +where +import GramLab.Morfette.LZipper +import qualified Data.Map as Map +import Data.Map ((!)) +import Data.List (sortBy) +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) => + [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 -> [Model a] -> [[Tok a]] -> [[Tok a]] +predict beamSize models sents = map predictOne sents + where predictOne s = fst + . head + . beamSearch beamSize models + $ [(fromList s,1)] + +predictPipeline :: Int -> [Model a] -> [[Tok a]] -> [[Tok a]] +predictPipeline beamSize models sents = map predictOne sents + where predictOne 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/GramLab/Morfette/Settings/Defaults.hs b/GramLab/Morfette/Settings/Defaults.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/Settings/Defaults.hs @@ -0,0 +1,15 @@ +module GramLab.Morfette.Settings.Defaults ( posTrainSettings + , lemmaTrainSettings + ) +where +import GramLab.Perceptron.Model + +lemmaTrainSettings = TrainSettings { iter = 10 + , rate = 0.1 + , occurTh = 40 + , entropyTh = 0.0 } +posTrainSettings = TrainSettings { iter = 20 + , rate = 0.1 + , occurTh = 40 + , entropyTh = 0.0 } + diff --git a/GramLab/Morfette/Token.hs b/GramLab/Morfette/Token.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/Token.hs @@ -0,0 +1,31 @@ +module GramLab.Morfette.Token ( Token + , Sentence + , tokenForm + , tokenLemma + , tokenPOS + , parseToken + , nullToken + , isNullToken + ) + +where + + +type Token = (String,Maybe String,Maybe String) +type Sentence = [Token] + +tokenForm (form,_,_) = form +tokenLemma (_,lemma,_) = lemma +tokenPOS (_,_,pos) = pos + +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 + +nullToken = ("",Nothing,Nothing) +isNullToken ("",Nothing,Nothing) = True +isNullToken _ = False + diff --git a/GramLab/Morfette/Utils.hs b/GramLab/Morfette/Utils.hs new file mode 100644 --- /dev/null +++ b/GramLab/Morfette/Utils.hs @@ -0,0 +1,255 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module GramLab.Morfette.Utils ( train + , predict + , Flag(..) + , morfette + ) +where +import Prelude hiding (print,getContents,putStrLn,putStr,writeFile,readFile) +import System.IO (stderr,stdout) +import System.IO.UTF8 +import GramLab.Commands +import qualified GramLab.Morfette.Models as Models +import GramLab.Morfette.Models (Smth(..)) +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Monad hiding (join) +import GramLab.Utils (padRight,splitWith,splitInto,join,tokenize,lowercase) +import qualified GramLab.Perceptron.Model as M +import GramLab.Morfette.Token +import GramLab.Morfette.LZipper +import GramLab.Morfette.MWE +import Data.Maybe +import System.Directory +import System.FilePath +import Text.Printf +import qualified Data.List as List +import Data.Char +import GramLab.Morfette.Lang.Conf +import GramLab.Morfette.BinaryInstances +import Data.Binary +import qualified Data.ByteString.Lazy as B +import qualified GramLab.Morfette.Config as C +import GramLab.Morfette.Evaluation +import GramLab.Morfette.Settings.Defaults + +data Flag = ModelPrefix String + | Eval + | BeamSize Int + | IgnoreCase + | DictFile FilePath + | BaselineFile FilePath + | Lang Lang + | Gaussian Double + | Tokenize + | IgnorePunct + | IgnorePOS String + | Pipeline + | EntropyTh Double + | IterPOS Int + | IterLemma Int + deriving Eq + +morfette fs fspecs = defaultMain (commands fs fspecs) "Usage: morfette command [OPTION...] [ARG...]" + +commands fs fspecs = [ + ("train" , CommandSpec (train fs fspecs) + "train models" + [ Option [] ["dict-file"] + (ReqArg DictFile "PATH") + "path to optional dictionary" + , Option [] ["language-configuration"] + (ReqArg Lang "es|pl|tr|..") + "language configuration" + , Option [] ["iter-pos"] + (ReqArg (IterPOS . read) "NUM") + "iterations for POS model" + , Option [] ["iter-lemma"] + (ReqArg (IterLemma . read) "NUM") + "iterations for Lemma model" + ] + [ "TRAIN-FILE", "MODEL-DIR" ]) + + , ("predict" , CommandSpec (predict fs fspecs) + "predict postags and lemmas using saved model data" + [ Option [] ["beam"] + (ReqArg (BeamSize . read) "+INT") + "beam size to use" + , Option [] ["tokenize"] + (NoArg Tokenize) + "tokenize input" + ] + [ "MODEL-DIR" ] ) + , ("eval" , CommandSpec eval + "evaluate morpho-tagging and lemmatization results" + [ Option [] ["ignore-case"] + (NoArg IgnoreCase) + "ignore case for evaluation" + , Option [] ["baseline-file"] + (ReqArg BaselineFile "PATH") + "path to baseline results" + , Option [] ["dict-file"] + (ReqArg DictFile "PATH") + "path to optional dictionary" + , Option [] ["ignore-punctuation"] + (NoArg IgnorePunct) + "ignore punctuation for evaluation" + , Option [] ["ignore-pos"] + (ReqArg IgnorePOS "POS-prefix") + "ignore POS starting with POS-prefix for evaluation" + ] + ["TRAIN-FILE","GOLD-FILE","TEST-FILE"]) + ] + + +predict (_,format) fspecs flags [modelprefix] = do + hPutStrLn stderr $ "Loading models from " ++ (modelFile modelprefix) + ms <- fmap decode (B.readFile (modelFile modelprefix)) + ms == ms `seq` return () + when True $ do + mwes <- loadMwes (mweFile modelprefix) + lex <- readConf (confFile modelprefix) + txt <- getContents + let models = zipWith Models.toModelFun (map ($lex) fspecs) ms + defaultBeamSize = 3 + n = case [f | BeamSize f <- flags ] + of { [f] -> f ; _ -> defaultBeamSize } + f = if Pipeline `elem` flags + then Models.predictPipeline + else Models.predict + putStr . unlines + . map format + . f n models + . toksToForms + . getToks flags mwes + $ txt + +confFile dir = dir "conf.model" +mweFile dir = dir "mwe.model" +modelFile dir = dir "models.model" +defaultGaussianPrior = 1 + +train (prepr,_) fspecs flags [dat,modeldir] = do + toks <- fmap (map parseToken . lines) (readFile dat) + dict <- getDict flags + 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 + [] -> M.entropyTh posTrainSettings + [f] -> f + i_p = case [f | IterPOS f <- flags ] of + [] -> M.iter posTrainSettings + [f] -> f + i_l = case [f | IterLemma f <- flags ] of + [] -> M.iter lemmaTrainSettings + [f] -> f + sentences = toksToSentences prepr toks + createDirectoryIfMissing True modeldir + let models = Models.train (map (\(i,fs) -> + let fs' = fs lex + ts = Models.trainSettings fs' + in fs' { Models.trainSettings = + ts { M.entropyTh = g + , M.iter = i + } }) + $ zip [i_p,i_l] fspecs) + $ sentences + B.writeFile (modelFile modeldir) (encode models) + saveConf (confFile modeldir) lex + saveMwes (mweFile modeldir) mwes + +toksToSentences :: (Token -> Models.Tok a) -> [Token] -> [[Models.Tok a]] +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 + +getDict :: [Flag] -> IO Lexicon +getDict flags = do + case [f | DictFile f <- flags ] of + [f] -> do + text <- readFile f + return (parseLexicon text) + [] -> return emptyLexicon + +getToks :: [Flag] -> [[String]] -> String -> [Token] +getToks flags mwes text = + let f = if Tokenize `elem` flags + then concatMap (detectMwes mwes) + . List.intersperse [""] + . map tokenize + else id + in map parseToken . f . lines $ text + + +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)) + 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 + keep tok = (not . ignore) tok && (not . isPunct) tok + train <- fmap uncase (getTokens trainf) + gold <- fmap uncase (getTokens goldf) + test <- fmap uncase (getTokens testf) + baseline <- case [f | BaselineFile f <- flags ] of + [] -> return Nothing + [f] -> fmap (Just . uncase) (getTokens f) + let keeps = map keep gold + return ( train + , filterZip keeps gold + , filterZip keeps test + , fmap (filterZip keeps) baseline ) + where getTokens f = fmap (map parseToken . lines) (readFile f) +-- 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) + isUnseenInDict (form,_,_) = not (lowercase form `Map.member` dict) + isUnseenBoth x = isUnseen x && isUnseenInDict x + all_acc = tokenAccuracy gold test baseline + unseen_acc = tokenAccuracy (filter isUnseen gold) (filter isUnseen test) + (fmap (filter isUnseen) baseline) + seen_acc = tokenAccuracy (filter (not . isUnseen) gold) (filter (not . isUnseen) test) + (fmap (filter (not . isUnseen)) baseline) + unseen_ratio = 100 * fromIntegral (length (filter isUnseen test)) / fromIntegral (length test) + unseen_train_and_dict_acc = tokenAccuracy (filter isUnseenBoth gold) + (filter isUnseenBoth test) + (fmap (filter isUnseenBoth) baseline) + sent_acc = sentenceAccuracy (sents gold) (sents test) (fmap sents baseline) + goldlemma g= map (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 + putStrLn $ "Token accuracy seen:\n" ++ showAccuracy seen_acc + putStrLn $ "Token accuracy unseen:\n" ++ showAccuracy unseen_acc + when (Map.size dict > 0) + (putStrLn $ "Token accuracy unseen train+dict:\n" ++ showAccuracy unseen_train_and_dict_acc) +-- FIXME Sentence accuracy is broken +-- putStrLn $ "Sentence accuracy:\n" ++ showAccuracy sent_acc + where toks xs = filter (not . isNullToken) xs + sents xs = splitWith isNullToken xs + +filterZip :: [Bool] -> [a] -> [a] +filterZip xs ys = catMaybes $ zipWith (\b x -> if b then Just x else Nothing) xs ys + + diff --git a/GramLab/Perceptron/IntModel.hs b/GramLab/Perceptron/IntModel.hs new file mode 100644 --- /dev/null +++ b/GramLab/Perceptron/IntModel.hs @@ -0,0 +1,72 @@ +module GramLab.Perceptron.IntModel ( IntModel + , train + , evalAll + , TrainSettings(..) + ) + +where +import qualified Data.IntSet as IntSet +import qualified Data.IntMap as IntMap +import qualified Data.Binary as B +import qualified Data.ByteString.Lazy as BS +import GramLab.Utils (padRight) +import Data.List (sortBy) +import Data.Ord (comparing) +import System.IO (stderr,hPutStrLn) +import Control.Monad (ap,liftM2) +import Data.Ix (inRange) + + +import qualified GramLab.Perceptron.Multiclass as P + +data TrainSettings = TrainSettings { iter :: Int + , rate :: Double + , occurTh :: Int + , entropyTh :: Double + } deriving (Eq,Show,Read) + +instance B.Binary TrainSettings where + put (TrainSettings a b c d) = B.put a >> B.put b >> B.put c >> B.put d + get = return TrainSettings `ap` B.get `ap` B.get `ap` B.get `ap` B.get + +data IntModel = IntModel { modelLabels :: IntSet.IntSet + , modelWeights :: P.Model } + deriving (Show,Eq) + +train :: TrainSettings -> [[Int]] -> [(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 ] + labels = map fst examples' + featids = concatMap (map fst . snd) examples' + weights = P.train (occurTh s) + (entropyTh s) + (realToFrac $ rate s) + (iter s) + (lo,hi) + yss + . map swap + $ examples' + model = IntModel { modelLabels = IntSet.fromList (map fst examples') + , modelWeights = weights + } + (lo,hi) = ((minimum labels,minimum featids) + ,(maximum labels,maximum featids)) :: ((Int,Int),(Int,Int)) + swap (x,y) = (y,x) + +evalAll :: IntModel -> [Int] -> [(Int,Double)] -> [(Int,Double)] +evalAll m ys fs = + let ((_,lo),(_,hi)) = P.bounds . modelWeights $ m + fs' = filter (\(k,_) -> inRange (lo,hi) k) fs + in map (\(i,v) -> (i,realToFrac v)) + . P.distribution (modelWeights m) ys + $ [ (i,realToFrac v) | (i,v) <- fs' ] +instance B.Binary IntModel where + put (IntModel ls ws) = B.put ls >> B.put ws + get = do + ls <- B.get + ls == ls `seq` return () + ws <- B.get + ws == ws `seq` return () + return $ IntModel ls ws + diff --git a/GramLab/Perceptron/Model.hs b/GramLab/Perceptron/Model.hs new file mode 100644 --- /dev/null +++ b/GramLab/Perceptron/Model.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE FlexibleContexts , BangPatterns #-} +module GramLab.Perceptron.Model ( train + , distribution + , classify + , save + , load + , I.TrainSettings(..) + , Model(..) + , ModelData(..) + , dump + , dumpMapping + , DumpMode(..) + ) +where +import qualified GramLab.Perceptron.IntModel as I +import qualified Data.ByteString.Lazy as BS +import qualified Data.Binary as B +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Map ((!)) +import Data.List (foldl') +import Data.Maybe (catMaybes) + +import Data.Char (isAlphaNum) +import GramLab.Intern +import GramLab.Data.Assoc +import GramLab.FeatureSet +import System.IO +import Debug.Trace + +type Example label features = (label,features) +data ModelData lab key sym num = + ModelData { featureMap :: Table (key,Maybe sym) + , settings :: I.TrainSettings + , classMap :: Map.Map lab Int + , inverseClassMap :: IntMap.IntMap lab + } deriving (Eq,Show) +data Model lab key sym num = Model { model :: I.IntModel + , modelData :: ModelData lab key sym num } + deriving (Eq,Show) + +invertMap = Map.foldWithKey (\k v m' -> IntMap.insert v k m') IntMap.empty +maxValues = IntMap.unionsWith max + +train :: (FeatureSet b key sym Double, Ord key, Ord sym, Ord a) => + I.TrainSettings + -> [[a]] + -> [(a, b)] + -> Model a key sym num +train p yss examples = + Model { model = m + , modelData = + ModelData { featureMap = fm + , settings = p + , classMap = cm + , inverseClassMap = invertMap cm + }} + where m = I.train p (map (map (cm !)) yss) samples + (ys,xs) = unzip examples + (ys',T _ cm) = flip runState initial $ mapM intern ys + (featsets,fm) = runState (mapM toFeatureSet xs) initial + samples = zipWith (\l fs -> (l,IntMap.toList fs)) + ys' + featsets + +pruneSingletonLabels :: (Ord y) => [(y,a)] -> [(y,a)] +pruneSingletonLabels yxs = + let counts = foldl' f Map.empty yxs + f !z (!y,_) = Map.insertWith' (+) y 1 z + in catMaybes [ if counts ! y > 1 then Just (y,x) else Nothing + | (y,x) <- yxs ] + + +pruneSingletonFeats :: (Ord y) => + [(y, [Feature String Double])] + -> [(y, [Feature String Double])] +pruneSingletonFeats yxs = + let counts = foldl' f Map.empty yxs + f !cxy (_,!x) = + foldl' (\z i -> case i of + Null -> z + Num _ -> z + Sym s -> Map.insertWith' (+) s 1 z + Set ss -> + foldl' (\z s -> Map.insertWith' (+) s 1 z) + z + ss) + cxy + x + in [ (y,[ case f of + Null -> Null + Num n -> Num n + Sym s -> if counts ! s > 1 then Sym s else Null + Set ss -> Set (filter (\s -> counts ! s > 1) ss) + | f <- x ]) + | (y,x) <- yxs ] + +data DumpMode = Write FilePath | Read FilePath | Skip deriving (Show,Read) +dump h examples = dumpMapping h Skip examples + + +dumpMapping h dm examples = do + (cm,fm) <- case dm of + Read p -> do + s <- BS.readFile p + return (B.decode s) + _ -> return (initial,initial) + let (ks,xs) = unzip examples + (labels,cm') = runState (mapM intern ks) cm + (featsets,fm') = runState (mapM toFeatureSet xs) fm + sm = maxValues featsets + samples = zipWith (\l fs -> (l,IntMap.toList fs)) + labels + featsets + format (l,fs) = unwords (show l + : map (\(f,v) -> show f ++ ":" ++ show v) fs) + mapM_ (hPutStrLn h . format) samples + case dm of + Write p -> BS.writeFile p (B.encode (cm',fm')) + _ -> return () + + +distribution m ys fs = fromAssoc $ map (\(k,v) -> (origClass k,v)) dist + where dist = I.evalAll (model m) (map (cm!) ys) s + cm = classMap . modelData $ m + s = IntMap.toList feats + feats = evalState (toFeatureSet fs) (featureMap . modelData $ m) + origClass k = + case IntMap.lookup k (inverseClassMap . modelData $ m) + of Just k' -> k' + Nothing -> error + $ "GramLab.Perceptron.Model.distribution: " + ++ "key not found: " ++ show k + +classify m ys = fst . head . distribution m ys + +instance (Ord a, B.Binary a) => B.Binary (Table a) where + put (T i m) = B.put i >> B.put m + get = liftM2 T B.get B.get + +instance (Ord lab, Ord key, Ord sym, + B.Binary lab, + B.Binary key, + B.Binary sym, + B.Binary num) => B.Binary (ModelData lab key sym num) where + put (ModelData fm s cm icm) = do + B.put fm + B.put s + B.put cm + B.put icm + get = do + fm <- B.get + fm == fm `seq` return () + s <- B.get + s == s `seq` return () + cm <- B.get + cm == cm `seq` return () + icm <- B.get + icm == icm `seq` return () + return $ ModelData fm s cm icm + +instance (Ord lab, Ord key, Ord sym, + B.Binary lab, + B.Binary key, + B.Binary sym, + B.Binary num) => B.Binary (Model lab key sym num) where + put (Model x y) = B.put x >> B.put y + get = do + x <- B.get + x == x `seq` return () + y <- B.get + y == y `seq` return () + return $ Model x y + +save path m = BS.writeFile path (B.encode m) +load path = fmap B.decode $ BS.readFile path + diff --git a/GramLab/Perceptron/Multiclass.hs b/GramLab/Perceptron/Multiclass.hs new file mode 100644 --- /dev/null +++ b/GramLab/Perceptron/Multiclass.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE BangPatterns , FlexibleContexts #-} +module GramLab.Perceptron.Multiclass + ( Model + , bounds + , train + , decode + , distribution + ) +where + +import Data.Array.ST +import qualified Data.Array.Unboxed as A +import Control.Monad.ST +import Data.STRef +import Control.Monad +import GramLab.Perceptron.Vector +import System.IO +import Data.List (foldl',sort) +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 Data.Maybe (isJust,fromMaybe) +import GramLab.Utils (uniq) +import Text.Printf (printf) +import Debug.Trace + +newtype Model = MC { weights :: DenseVector (Y,I) + } deriving (Eq,Show) + +bounds = A.bounds . weights + +instance B.Binary Model where + put (MC m) = do + let (lo,hi) = A.bounds m + xs = filter (\(_,e) -> e /= 0.0) . A.assocs $ m + B.put (lo,hi) + B.put xs + get = do + (lo,hi) <- B.get + xs <- B.get + xs == xs `seq` return () + return $ MC (A.accumArray (+) 0 (lo,hi) $ xs) + +type Y = Int +type X = [(I,Float)] +type I = Int + +{-# INLINE phi #-} +phi :: X -> Y -> (X,Y) +phi x y = (x,y) + +{-# INLINE decode #-} +decode :: Model -> [Y] -> X -> Y +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)) + -> [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 + + +{-# 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 + in [ exp $ x_i - x_max - log a | !x_i <- x ] + +{-# INLINE distribution #-} +distribution :: Model -> [Y] -> X -> [(Y, Float)] +distribution (MC w) ys x = + let swap (!x,!y) = (y,x) + fxs = map ((w`dot`) . phi x) ys + in reverse . map swap . sort $ zip (softmax fxs) ys + +iter :: Float + -> [[Y]] + -> [(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 + params' <- unsafeFreeze params + let y'= decode (MC params') ys' x + phi_xy = phi x y + phi_xy' = phi x y' + when (y' /= y) $ do + params `plus_` (phi_xy `scale` rate) + params `plus_` (phi_xy' `scale` (rate * (-1))) + c' <- readSTRef c + params_a `plus_` (phi_xy `scale` (rate * fromIntegral c')) + params_a `plus_` (phi_xy' `scale` (rate * (-1) * fromIntegral c')) + modifySTRef c (+1) + +train :: Int + -> Double + -> Float + -> Int + -> ((Y,I), (Y,I)) + -> [[Y]] + -> [(X, Y)] + -> Model +train th1 th2 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 + 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 / + fromIntegral (length xys) + runLogger + $ hPutStrLn stderr + $ printf "Iteration %d: error: %2.4f" i err + finalParams (c, params, params_a) + return params + +finalParams :: (STRef s Int, DenseVectorST s (Y,I), DenseVectorST s (Y,I)) + -> ST s () +finalParams (c,params,params_a) = do + (l,u) <- getBounds params + c' <- fmap fromIntegral (readSTRef c) + for_ (range (l,u)) $ \i -> do + e <- readArray params i + e_a <- readArray params_a i + writeArray params i (e - (e_a * (1/c'))) + +{-# NOINLINE runLogger #-} +runLogger f = unsafeIOToST f + +m `at` i = Map.findWithDefault 0 i m + +counts_x :: [(X,Y)] -> (Map.Map (I,Y) Int + ,Map.Map I Int + ,Map.Map Y Int) +counts_x xys = foldl' f (Map.empty,Map.empty,Map.empty) xys + where f (!cxy,!cx,!cy) (!x,!y) = + ( foldl' (\z (i,_) -> Map.insertWith' (+) (i,y) 1 z) cxy x + , foldl' (\z (i,_) -> Map.insertWith' (+) i 1 z) cx x + , Map.insertWith' (+) y 1 cy ) + +sum :: (Num n) => [n] -> n +{-# SPECIALIZE INLINE sum :: [Double] -> Double #-} +{-# SPECIALIZE INLINE sum :: [Float] -> Float #-} +sum = foldl' (+) 0 diff --git a/GramLab/Perceptron/Vector.hs b/GramLab/Perceptron/Vector.hs new file mode 100644 --- /dev/null +++ b/GramLab/Perceptron/Vector.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE FlexibleContexts, BangPatterns #-} +module GramLab.Perceptron.Vector + ( SparseVector + , DenseVector + , DenseVectorST + , for_ + , plus_ + , scale + , dot + , dot_ + , unsafeDot + ) +where + +import Data.Array.ST +import Data.Array.Unboxed (UArray,bounds,(!)) +import Control.Monad.ST +import Data.STRef +import GHC.Arr (unsafeIndex) +import Data.Array.Base (unsafeAt) + +type SparseVector y i = ([(i,Float)],y) +type DenseVectorST s i = STUArray s i Float +type DenseVector i = UArray i Float + + +{-# INLINE for_ #-} +for_ xs f = mapM_ f xs + + +{-# SPECIALIZE plus_ :: DenseVectorST s (Int,Int) + -> SparseVector Int Int -> ST s () #-} +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) + writeArray w (y,i) (wi + vi) + +{-# SPECIALIZE scale :: SparseVector Int Int + -> Float + -> SparseVector Int Int #-} +scale :: (Ix i) => SparseVector y i -> Float -> SparseVector y i +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 w (x,!y) = go 0 x + 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)) + -> ([(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 + +{-# INLINE unsafeDot #-} +{-# SPECIALIZE unsafeDot :: DenseVector (Int,Int) + -> ([(Int,Float)],Int)-> Float #-} +unsafeDot :: (Ix (y,i)) => DenseVector (y,i) -> ([(i,Float)],y) -> Float +unsafeDot w (x,!y) = go 0 x + where bs = bounds w + go !s [] = s + go !s ((!i,!xi):x) = go (s + unsafeAt w (unsafeIndex bs (y,i)) * xi) x + diff --git a/GramLab/Utils.hs b/GramLab/Utils.hs new file mode 100644 --- /dev/null +++ b/GramLab/Utils.hs @@ -0,0 +1,98 @@ +module GramLab.Utils ( join + , splitOn + , splitWith + , splitInto + , padLeft + , padRight + , makeList + , lowercase + , uppercase + , at + , distribute + , distributeOver + , cumulDifference + , index + , unfoldrM + , tokenize + , uniq + ) + +where +import Data.List +import Data.Char +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set +import qualified Data.Traversable as T +import qualified Control.Monad.State as S +import Control.Monad (liftM) +import Debug.Trace +-- Lists/Strings +join :: [a] -> [[a]] -> [a] +join sep xs = concat $ intersperse sep xs + +splitOn :: (Eq a) => a -> [a] -> [[a]] +splitOn = splitWith . (==) + +splitWith :: (a -> Bool) -> [a] -> [[a]] +splitWith f s = case dropWhile f s of + [] -> [] + s' -> w : splitWith f s'' + where (w, s'') = break f s' + +splitInto :: Int -> [a] -> [[a]] +splitInto size [] = [] +splitInto size xs = let (ws,ys) = splitAt size xs + in ws:splitInto size ys + +padLeft :: a -> Int -> [a] -> [a] +padLeft pad size xs = reverse $ padRight pad size $ reverse xs + +padRight :: a -> Int -> [a] -> [a] +padRight pad size xs = take size (xs ++ (repeat pad)) + +lowercase :: String -> String +--lowercase xs | trace xs False = undefined +lowercase xs = map toLower xs + +uppercase :: String -> String +uppercase = map toUpper + +makeList size elt = take size (repeat elt) + +at err m k = case Map.lookup k m of + Nothing -> error (err k) + Just x -> x + +distributeOver :: Int -> [t] -> [[t]] +distributeOver i = distribute ([],(replicate i [])) + +distribute (xs,ys) [] = xs ++ ys +distribute (xs,[]) zs = distribute ([],xs) zs +distribute (xs,y:ys) (z:zs) = distribute ((z:y):xs,ys) zs + +cumulDifference :: (Ord a) => [Set a] -> [Set a] +cumulDifference = snd . mapAccumL (\z x -> (z `Set.union` x, x `Set.difference` z)) Set.empty + +index xs = S.evalState (T.mapM count xs) 0 + where count a = do + i <- S.get + S.put (i+1) + return (i,a) +unfoldrM f b = do + result <- f b + case result of + Just (a,new_b) -> liftM (a:) (unfoldrM f new_b) + Nothing -> return [] + +sepPunct :: String -> [String] +sepPunct xs = let (before,rest) = span isPunctuation xs + (after,this) = span isPunctuation (reverse rest) + in filter (not . null) [before,reverse this,reverse after] +tokenize :: String -> [String] +tokenize = concatMap sepPunct . words + + +uniq :: (Ord a) => [a] -> [a] +{-# SPECIALIZE INLINE uniq :: [String] -> [String] #-} +uniq = Set.toList . Set.fromList diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2010, Grzegorz Chrupala +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Lemma.hs b/Lemma.hs new file mode 100644 --- /dev/null +++ b/Lemma.hs @@ -0,0 +1,42 @@ +module Lemma (featureSpec,apply,make) +where +import qualified Data.Map as Map +import GramLab.Morfette.Features.Common +import qualified GramLab.Data.Diff.EditTree as E +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) = E.check s (prepare (getForm (fromMaybe (error "Lemma.featureSpec.check: Nothing") + (focus z)))) +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 + +getForm = str . head + +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) + ] + ++ prefixes maxPrefix (low form) + ++ 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) + +decode str = case reads str of + [(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) diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,14 @@ + +import GramLab.Utils (splitWith,join,lowercase) + +import qualified POS as P +import qualified Lemma as L +import GramLab.Morfette.Models +import GramLab.Morfette.Utils (morfette) + +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 + +prep (f,Just l, Just p) = [Str f,Str p, L.make f l] diff --git a/POS.hs b/POS.hs new file mode 100644 --- /dev/null +++ b/POS.hs @@ -0,0 +1,41 @@ +module POS (featureSpec) +where +import GramLab.Morfette.Features.Common +import qualified GramLab.Data.Diff.EditTree as E +import qualified Data.Map as Map +import Lemma (apply) +featureSpec global = FS { label = (!!1) + , features = theFeatures global + , preprune = mkPreprune 0.3 + , check = \_ _ -> True + , trainSettings = posTrainSettings } + +leftCtx = 2 +rightCtx = 1 + +maxSuffix = 7 +maxPrefix = 5 + + +theFeatures global tic = let prev = getSome leftCtx (left tic) + 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 + , Sym $ apply script (low form) + , Sym $ low form ] + leftFeatures Nothing = [Null , Null , Null] + focusFeatures (Just (Str form:_)) = [ Sym $ low form + , Sym $ spellingSpec form + , lexmap (low form) ] + ++ prefixes maxPrefix (low form) + ++ suffixes maxSuffix (low form) + 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) + getpos Nothing = "" + getpos (Just (Str form:Str label:_)) = head (splitPOS (lang global) label) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,115 @@ +=INTRODUCTION= + +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 +learns how to morphologically analyse new sentences. + +In the learning stage Morfette fits two separate logistic regression +models: one for morphological tagging and one for lemmatization. The +predictions of the models are combined dynamically and produce a +globally plausible sequence of morphological-tag - lemma pairs for +a sentence. + +In Morfette lemmatization is cast as a classification task where a +a lemmatization class corresponds to the specification of the edit +operations which are needed to transform the inflected word form into +the corresponding lemma. + +The basic approach is described in (Chrupala et al 2008 and Chrupala 2008). +The current version of Morfette uses an averaged perceptron to +fit the models, rather than Maximum Entropy training. The lemmatization +classes are Edit-Tree-based as described in (Chrupala 2008). + +=LICENSE= +The source code in the src directory is licensed under +the BSD license. + +=INSTALLATION= +Pre-built binaries are available from the project website. +If they don't work on your system you will +need to build from source, using the GHC Haskell compiler. Build +instructions are in [INSTALL] + +=USAGE= +Usage: morfette command [OPTION...] [ARG...] +train: train models +train [OPTION...] TRAIN-FILE MODEL-DIR + --dict-file=PATH path to optional dictionary + --language-configuration=es|pl|tr|.. language configuration + --class-entropy-prune-threshold=NUM class prune threshold + +predict: predict postags and lemmas using saved model data +predict [OPTION...] MODEL-DIR + --beam=+INT beam size to use + --tokenize tokenize input + +eval: evaluate morpho-tagging and lemmatization results +eval [OPTION...] TRAIN-FILE GOLD-FILE TEST-FILE + --ignore-case ignore case for evaluation + --baseline-file=PATH path to baseline results + --dict-file=PATH path to optional dictionary + --ignore-punctuation ignore punctuation for evaluation + --ignore-pos=POS-prefix ignore POS starting with POS-prefix for evaluation + + +=EXAMPLE USAGE= +To train a new model: +morfette train --dict-file=DICT TRAINING-FILE MODEL-DIR + +To use the model in MODEL-DIR to analyze new data: +morfette predict MODEL-DIR < TEST-DATA > ANALYZED-TEST-DATA + +=DATA FORMAT= +Morfette expects both training and testing data to be tokenized and +split into sentences. The format of training data look like this: + +Gómez Gómez np0000p +sostiene sostener vmip3s0 +que que cs +la el da0fs0 +propuesta propuesta ncfs000 +no no rn +cambiará cambiar vmif3s0 +. . Fp + +La el da0fs0 +propuesta propuesta ncfs000 +será ser vsif3s0 +la el da0fs0 +misma mismo pi0fs000 + + +There is one token per line, with three columns separated by spaces or +tabs. The columns contain word form, lemma and morphological tag +respectively. Sentences are separated by an empty line. Text should be +encoded in UTF-8. + +Test data format is similar, except only the first column is needed: + +Gómez +sostiene +que +la +propuesta +no +cambiará +. + +La +propuesta +será +la +misma + + +=References= +[1] Grzegorz Chrupala, Georgiana Dinu and Josef van Genabith. 2008. + Learning Morphology with Morfette. In Proceedings of LREC 2008. + http://www.lrec-conf.org/proceedings/lrec2008/pdf/594_paper.pdf + +[2] Grzegorz Chrupala. 2008. Towards a Machine-Learning Architecture + for Lexical Functional Grammar Parsing. Chapter 6. PhD + dissertation, Dublin City + University. + http://www.lsv.uni-saarland.de/personalPages/gchrupala/papers/phd.pdf diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#! /usr/bin/env runhaskell + +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/morfette.cabal b/morfette.cabal new file mode 100644 --- /dev/null +++ b/morfette.cabal @@ -0,0 +1,36 @@ +Name: morfette +Version: 0.2 +Synopsis: Morfette: 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 + learns how to morphologically analyse new sentences. +License: BSD3 +License-file: LICENSE +Author: Grzegorz Chrupała +Maintainer: Grzegorz Chrupała +build-type: Simple +category: Natural Language Processing +Extra-source-files: README + +Executable: morfette +Main-Is: Main.hs +Other-Modules: GramLab.Commands, GramLab.Morfette.LZipper, + GramLab.Data.LCS.SimpleMemo, GramLab.Data.Diff.EditListRev, + GramLab.Data.Diff.EditList, GramLab.Data.StringLike, + GramLab.Data.CommonSubstrings, GramLab.Data.Diff.EditTree, + GramLab.Morfette.BinaryInstances, + GramLab.Morfette.Token, GramLab.Binomial, + GramLab.Perceptron.Vector, GramLab.Data.Assoc, + GramLab.Intern, GramLab.Utils, GramLab.Perceptron.Multiclass, + 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.Settings.Defaults, + GramLab.Morfette.Features.Common, + Lemma, POS, GramLab.Morfette.Utils +Build-depends: base >=3 && <=4 , containers, array, QuickCheck, mtl, + directory, filepath, haskell98, pretty, + utf8-string, bytestring, binary +cc-options: -Wall