diff --git a/GramLab/Binomial.hs b/GramLab/Binomial.hs deleted file mode 100644 --- a/GramLab/Binomial.hs +++ /dev/null @@ -1,60 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Commands.hs +++ /dev/null @@ -1,54 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Data/Assoc.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/Data/CommonSubstrings.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/Data/Diff/EditList.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/Data/Diff/EditListRev.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/Data/Diff/EditTree.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/Data/LCS/SimpleMemo.hs +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------ --- 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 deleted file mode 100644 --- a/GramLab/Data/StringLike.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/FeatureSet.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/Intern.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/Morfette/BinaryInstances.hs +++ /dev/null @@ -1,28 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Morfette/Config.hs +++ /dev/null @@ -1,19 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Morfette/Evaluation.hs +++ /dev/null @@ -1,78 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Morfette/Features/Common.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/GramLab/Morfette/LZipper.hs +++ /dev/null @@ -1,48 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Morfette/Lang/Conf.hs +++ /dev/null @@ -1,82 +0,0 @@ -module GramLab.Morfette.Lang.Conf ( Lexicon - , Conf(..) - , Lang - , makeConf - , emptyLexicon - , saveConf - , readConf - , 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)] -data Conf = Conf { dictLex :: Lexicon - , lang :: Lang } deriving (Eq) - -instance Binary Conf where - put (Conf x y) = put x >> put y - get = do - x <- get - y <- get - return (Conf x y) - -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) - -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 - -parseEntry :: String -> [(String,(String, String))] -parseEntry line = - let (form:pairs) = words line - 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/MWE.hs b/GramLab/Morfette/MWE.hs deleted file mode 100644 --- a/GramLab/Morfette/MWE.hs +++ /dev/null @@ -1,44 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Morfette/Models.hs +++ /dev/null @@ -1,144 +0,0 @@ -module GramLab.Morfette.Models ( train - , trainFun - , predict - , predictPipeline - , toModelFun - , mkPreprune - , sentToExamples - , FeatureSpec (..) - , Smth(..) - , Tok - ) -where -import GramLab.Morfette.LZipper -import qualified Data.Map as Map -import Data.Map ((!)) -import Data.List (sortBy) -import Data.Ord (comparing) -import Data.Dynamic -import GramLab.FeatureSet -import qualified GramLab.Perceptron.Model as M -import Data.Traversable (forM) -import qualified Data.IntMap as IntMap -import Data.Maybe (fromMaybe) -import Debug.Trace -import Data.Binary -import Control.Monad (liftM) -import GramLab.Utils (uniq) - -data Smth a = Str { str :: String } | ES { es :: a } deriving (Eq,Ord,Show,Read) -instance Binary a => Binary (Smth a) where - put (Str s) = put (0::Word8) >> put s - put (ES s) = put (1::Word8) >> put s - get = do - tag <- get - case tag::Word8 of - 0 -> liftM Str get - 1 -> liftM ES get - -type ProbDist a = [(a,Double)] - -type Tok a = [Smth a] -type Model a = LZipper [Smth a] [Smth a] [Smth a] -> ProbDist (Smth a) -beamSearch :: - Int -- beam size - -> [Model a] - -> ProbDist (LZipper (Tok a) (Tok a) (Tok a)) - -- prob dist over sequence of "tokens in context" (as lzippers) - -> ProbDist [Tok a] -- prob dist over sequences of "tokens" -beamSearch n cfs pzs = - if any (atEnd . fst) pzs - -- of any lzipper at end then get then return tokens - then flip map pzs $ \(z,p) -> (map id (reverse (left z)),p) - else -- otherwise apply each classifier in turn in the lzipper seq, - -- prune, adjust probs - let f pzs' model = prune n - . flip concatMap pzs' - $ \(z,p) -> - flip map (model $ z) - $ \(c,c_p) -> - (modify (\x -> x ++ [c]) z,p*c_p) - in beamSearch n cfs . map (\(z,p) -> (slide z,p)) $! (foldl f pzs cfs) - --- pruning and prepruning - -prune :: Int -> ProbDist a -> ProbDist a -prune n = take n . sortBy (flip (comparing snd)) -collectUntil cond f z [] = [] -collectUntil cond f z (x:xs) = let z' = (f $! x) $! z - in if cond x z' then [] - else x: collectUntil cond f z' xs -mkPreprune th = collectUntil (\x z -> th > snd x / z) ((+) . snd) 0 - -data FeatureSpec a = - FS { label :: Tok a -> Smth a - , features :: LZipper (Tok a) (Tok a) (Tok a) -> [Feature String Double] - , preprune :: ProbDist (Smth a) -> ProbDist (Smth a) - , check :: LZipper (Tok a) (Tok a) (Tok a) -> Smth a -> Bool - , trainSettings :: M.TrainSettings } - -trainFun :: (Ord a,Show a) => [FeatureSpec a] -> [[Tok a]] -> [Model a] -trainFun fspecs sents = - let ms = train fspecs sents - in (zipWith toModelFun fspecs ms) - -train :: (Ord a,Show a) => - [FeatureSpec a] - -> [[Tok a]] - -> [M.Model (Label a) Int String Double] -train fspecs sents = - flip map fspecs - $ \fs -> let yxs = concatMap (sentToExamples fs) $ sents - ys = uniq . map fst $ yxs - zs = concat [ take (length s) - . iterate slide - . fromList - $ s - | s <- sents ] - yss = [ [ y | y <- ys , check fs z y ] - | z <- zs ] - in M.train (trainSettings fs) yss yxs - -toModelFun :: (Ord a,Show a) => - FeatureSpec a - -> (M.Model (Label a) Int String Double) - -> Model a -toModelFun fs m = - let ys = Map.keys . M.classMap . M.modelData $ m - in - \ z -> case filter (check fs z) ys of - [] -> error "GramLab.Morfette.Models.toModelFun: unexpected []" - y:ys' -> - preprune fs - . M.distribution m (y:ys') - . features fs - $ z - -predict :: Int -> [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 deleted file mode 100644 --- a/GramLab/Morfette/Settings/Defaults.hs +++ /dev/null @@ -1,15 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Morfette/Token.hs +++ /dev/null @@ -1,31 +0,0 @@ -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 deleted file mode 100644 --- a/GramLab/Morfette/Utils.hs +++ /dev/null @@ -1,332 +0,0 @@ -{-# 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 qualified Data.IntMap as IntMap -import Control.Monad hiding (join) -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 -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 -import GramLab.Intern (Table(..),intern,initial,runState,evalState) -import GramLab.FeatureSet (toFeatureSet,FeatureSet) -import Debug.Trace - -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 - | ModelId String - 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" ]) - , ("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" - [ 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" -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) - let tokSet = Set.fromList [ s | t@(s,_,_) <- toks ] - dict <- getDict flags Nothing - let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f } - lex = Conf { dictLex = dict - , 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] -> Maybe (Set.Set String) -> IO Lexicon -getDict flags tokSet = do - case [f | DictFile f <- flags ] of - [f] -> do - d <- fmap (parseLexicon tokSet) $ readFile f - return d - [] -> 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 - (train,gold,test,baseline) <- fmap (\ (tr, g, t, b) -> (tr,toks g, toks t, fmap toks b)) (getEval flags trainf goldf testf) - let seen = Set.fromList (map tokenForm train) - dict <- getDict flags . Just $ seen - let isUnseen (form,_,_) = not (form `Set.member` seen) - isUnseenInDict (form,_,_) = not (lowercase form `Map.member` dict) - 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 deleted file mode 100644 --- a/GramLab/Perceptron/IntModel.hs +++ /dev/null @@ -1,72 +0,0 @@ -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 Data.Array.Unboxed - -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 -> 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 ] - examples'' = map swap examples' - labels = map fst examples' - featids = concatMap (map fst . snd) examples' - weights = examples'' == examples'' `seq` P.train (realToFrac $ rate s) - (iter s) - (lo,hi) - yss - $ examples'' - model = IntModel { modelLabels = IntSet.fromList labels - , 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 deleted file mode 100644 --- a/GramLab/Perceptron/Model.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# 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 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 -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 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)) - 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 deleted file mode 100644 --- a/GramLab/Perceptron/Multiclass.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# 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 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) -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' :: (Float, DenseVector (Y,I), DenseVector (Y,I)) - -> [Y] - -> X - -> Y -decode' w ys x = snd . maximum - $ [ (w`dot'`phi x y,y) | 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 - -> 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 - let ((_,lo),(_,hi)) = A.bounds yss - ys = [lo..hi] - for_ (zip [0..] ss) $ \ (i,(x,y)) -> do - params' <- unsafeFreeze params - 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 - 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 :: Float - -> Int - -> ((Y,I), (Y,I)) - -> A.UArray (Int,Int) Bool - -> [(X, Y)] - -> Model -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) - 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 - $ 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 deleted file mode 100644 --- a/GramLab/Perceptron/Vector.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# 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' :: (Float,DenseVector (Int,Int),DenseVector (Int,Int)) - -> ([(Int,Float)],Int) - -> 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) - -> ([(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 deleted file mode 100644 --- a/GramLab/Utils.hs +++ /dev/null @@ -1,98 +0,0 @@ -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/Lemma.hs b/Lemma.hs deleted file mode 100644 --- a/Lemma.hs +++ /dev/null @@ -1,42 +0,0 @@ -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 (show . make w . fst) $ 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 deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,16 +0,0 @@ - -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 = 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/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,8 +1,11 @@ defaults: all + + + #program name -MORFETTE=../src/dist/build/morfette/morfette +MORFETTE=dist/build/morfette/morfette #parameters for training and eval @@ -10,15 +13,15 @@ # for french TYPE can be either ftb4 or ftbmax TYPE=ftb4 -TRAINDATADIR=../DATA/ +TRAINDATADIR=DATA/ PREF=${TRAINDATADIR}/${TYPE} TRAINSET=${PREF}/ftb_1.pos.utf8.morpheteready DEVSET=${PREF}/ftb_2.pos.utf8.morpheteready GOLDSET=${PREF}/ftb_3.pos.utf8.morpheteready LEXICON=${TRAINDATADIR}/lexicon/lexicon.ftb4.4morfette.csv -ITERPOS=5 -ITERLEMMA=2 +ITERPOS=10 +ITERLEMMA=3 MODELNAME=${PREF}/${TYPE}.${ITERPOS}x${ITERLEMMA}.model all: configure build @@ -27,15 +30,28 @@ check: train eval_dev + +# note that if you want to install in your own home directory +# add a --prefix=DIRTOINSTALL option right after the --user +# as in +# runghc Setup.lhs configure --user --prefix=/home/foo/bar +# the install target will then install the morfette compiled binary +# in /home/foo/bar/bin (bin must exist) + configure: runghc Setup.lhs configure --user + build: configure runghc Setup.lhs build -install: +install: configure build runghc Setup.lhs install + +install_home: + + clean: runghc Setup.lhs clean @@ -50,8 +66,8 @@ eval_dev: - ${MORFETTE} predict ${MODELNAME} < ${DEVSET} > ${DEVSET}.tagged - ${MORFETTE} eval --ignore-case ${TRAINSET} ${DEVSET} ${DEVSET}.tagged |\ + #${MORFETTE} predict ${MODELNAME} < ${DEVSET} > ${DEVSET}.tagged + ${MORFETTE} eval --ignore-case /dev/null ${DEVSET} ${DEVSET}.tagged |\ tee ${DEVSET}.tagged.result.${TYPE}.${ITERPOS}x${ITERLEMMA}.model diff --git a/POS.hs b/POS.hs deleted file mode 100644 --- a/POS.hs +++ /dev/null @@ -1,41 +0,0 @@ -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 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,5 +1,5 @@ Name: morfette -Version: 0.3.1 +Version: 0.3.2 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 @@ -15,12 +15,11 @@ Extra-source-files: README, INSTALL, Makefile Executable: morfette +hs-source-dirs: src 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.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, @@ -31,7 +30,7 @@ GramLab.Morfette.Settings.Defaults, GramLab.Morfette.Features.Common, Lemma, POS, GramLab.Morfette.Utils -Build-depends: base >=3 && <=4 , containers, array, QuickCheck, mtl, +Build-depends: base >=3 && <=5 , containers, array, mtl, directory, filepath, haskell98, pretty, - utf8-string, bytestring, binary + utf8-string, bytestring, binary, QuickCheck >= 2.3 cc-options: -Wall diff --git a/src/GramLab/Binomial.hs b/src/GramLab/Binomial.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Commands.hs b/src/GramLab/Commands.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Data/Assoc.hs b/src/GramLab/Data/Assoc.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Data/CommonSubstrings.hs b/src/GramLab/Data/CommonSubstrings.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Data/Diff/EditTree.hs b/src/GramLab/Data/Diff/EditTree.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Data/Diff/EditTree.hs @@ -0,0 +1,64 @@ +{-# 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 +import Data.Binary +import Control.Monad (liftM2,liftM4) + +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 + + +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 diff --git a/src/GramLab/Data/StringLike.hs b/src/GramLab/Data/StringLike.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/FeatureSet.hs b/src/GramLab/FeatureSet.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Intern.hs b/src/GramLab/Intern.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Morfette/Config.hs b/src/GramLab/Morfette/Config.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Morfette/Evaluation.hs b/src/GramLab/Morfette/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Morfette/Features/Common.hs b/src/GramLab/Morfette/Features/Common.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Morfette/LZipper.hs b/src/GramLab/Morfette/LZipper.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Morfette/Lang/Conf.hs b/src/GramLab/Morfette/Lang/Conf.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Morfette/Lang/Conf.hs @@ -0,0 +1,82 @@ +module GramLab.Morfette.Lang.Conf ( Lexicon + , Conf(..) + , Lang + , makeConf + , emptyLexicon + , saveConf + , readConf + , 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)] +data Conf = Conf { dictLex :: Lexicon + , lang :: Lang } deriving (Eq) + +instance Binary Conf where + put (Conf x y) = put x >> put y + get = do + x <- get + y <- get + return (Conf x y) + +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) + +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 + +parseEntry :: String -> [(String,(String, String))] +parseEntry line = + let (form:pairs) = words line + 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/src/GramLab/Morfette/MWE.hs b/src/GramLab/Morfette/MWE.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Morfette/Models.hs b/src/GramLab/Morfette/Models.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Morfette/Models.hs @@ -0,0 +1,144 @@ +module GramLab.Morfette.Models ( train + , trainFun + , predict + , predictPipeline + , toModelFun + , mkPreprune + , sentToExamples + , FeatureSpec (..) + , Smth(..) + , Tok + ) +where +import GramLab.Morfette.LZipper +import qualified Data.Map as Map +import Data.Map ((!)) +import Data.List (sortBy) +import Data.Ord (comparing) +import Data.Dynamic +import GramLab.FeatureSet +import qualified GramLab.Perceptron.Model as M +import Data.Traversable (forM) +import qualified Data.IntMap as IntMap +import Data.Maybe (fromMaybe) +import Debug.Trace +import Data.Binary +import Control.Monad (liftM) +import GramLab.Utils (uniq) + +data Smth a = Str { str :: String } | ES { es :: a } deriving (Eq,Ord,Show,Read) +instance Binary a => Binary (Smth a) where + put (Str s) = put (0::Word8) >> put s + put (ES s) = put (1::Word8) >> put s + get = do + tag <- get + case tag::Word8 of + 0 -> liftM Str get + 1 -> liftM ES get + +type ProbDist a = [(a,Double)] + +type Tok a = [Smth a] +type Model a = LZipper [Smth a] [Smth a] [Smth a] -> ProbDist (Smth a) +beamSearch :: + Int -- beam size + -> [Model a] + -> ProbDist (LZipper (Tok a) (Tok a) (Tok a)) + -- prob dist over sequence of "tokens in context" (as lzippers) + -> ProbDist [Tok a] -- prob dist over sequences of "tokens" +beamSearch n cfs pzs = + if any (atEnd . fst) pzs + -- of any lzipper at end then get then return tokens + then flip map pzs $ \(z,p) -> (map id (reverse (left z)),p) + else -- otherwise apply each classifier in turn in the lzipper seq, + -- prune, adjust probs + let f pzs' model = prune n + . flip concatMap pzs' + $ \(z,p) -> + flip map (model $ z) + $ \(c,c_p) -> + (modify (\x -> x ++ [c]) z,p*c_p) + in beamSearch n cfs . map (\(z,p) -> (slide z,p)) $! (foldl f pzs cfs) + +-- pruning and prepruning + +prune :: Int -> ProbDist a -> ProbDist a +prune n = take n . sortBy (flip (comparing snd)) +collectUntil cond f z [] = [] +collectUntil cond f z (x:xs) = let z' = (f $! x) $! z + in if cond x z' then [] + else x: collectUntil cond f z' xs +mkPreprune th = collectUntil (\x z -> th > snd x / z) ((+) . snd) 0 + +data FeatureSpec a = + FS { label :: Tok a -> Smth a + , features :: LZipper (Tok a) (Tok a) (Tok a) -> [Feature String Double] + , preprune :: ProbDist (Smth a) -> ProbDist (Smth a) + , check :: LZipper (Tok a) (Tok a) (Tok a) -> Smth a -> Bool + , trainSettings :: M.TrainSettings } + +trainFun :: (Ord a,Show a) => [FeatureSpec a] -> [[Tok a]] -> [Model a] +trainFun fspecs sents = + let ms = train fspecs sents + in (zipWith toModelFun fspecs ms) + +train :: (Ord a,Show a) => + [FeatureSpec a] + -> [[Tok a]] + -> [M.Model (Label a) Int String Double] +train fspecs sents = + flip map fspecs + $ \fs -> let yxs = concatMap (sentToExamples fs) $ sents + ys = uniq . map fst $ yxs + zs = concat [ take (length s) + . iterate slide + . fromList + $ s + | s <- sents ] + yss = [ [ y | y <- ys , check fs z y ] + | z <- zs ] + in M.train (trainSettings fs) yss yxs + +toModelFun :: (Ord a,Show a) => + FeatureSpec a + -> (M.Model (Label a) Int String Double) + -> Model a +toModelFun fs m = + let ys = Map.keys . M.classMap . M.modelData $ m + in + \ z -> case filter (check fs z) ys of + [] -> error "GramLab.Morfette.Models.toModelFun: unexpected []" + y:ys' -> + preprune fs + . M.distribution m (y:ys') + . features fs + $ z + +predict :: Int -> [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/src/GramLab/Morfette/Settings/Defaults.hs b/src/GramLab/Morfette/Settings/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Morfette/Token.hs b/src/GramLab/Morfette/Token.hs new file mode 100644 --- /dev/null +++ b/src/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/src/GramLab/Morfette/Utils.hs b/src/GramLab/Morfette/Utils.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Morfette/Utils.hs @@ -0,0 +1,340 @@ +{-# 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,stdin,hSetBinaryMode) +import System.IO.UTF8 hiding (getContents,print,putStr,putStrLn) +import qualified System.IO.UTF8 as UTF8 +import GramLab.Commands +import qualified GramLab.Morfette.Models as Models +import GramLab.Morfette.Models (Smth(..)) +import qualified 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,splitOn + ,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 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 +import GramLab.Intern (Table(..),intern,initial,runState,evalState) +import GramLab.FeatureSet (toFeatureSet,FeatureSet) +import Debug.Trace + +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 + | ModelId String + 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" ]) + , ("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" + [ 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" +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) + let tokSet = Set.fromList [ s | t@(s,_,_) <- toks ] + dict <- getDict flags Nothing + let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f } + lex = Conf { dictLex = dict + , 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] -> Maybe (Set.Set String) -> IO Lexicon +getDict flags tokSet = do + case [f | DictFile f <- flags ] of + [f] -> do + d <- fmap (parseLexicon tokSet) $ readFile f + return d + [] -> 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 + (train,gold,test,baseline) <- fmap (\ (tr, g, t, b) -> (tr,toks g, toks t, fmap toks b)) (getEval flags trainf goldf testf) + let seen = Set.fromList (map tokenForm train) + dict <- getDict flags . Just $ seen + let isUnseen (form,_,_) = not (form `Set.member` seen) + isUnseenInDict (form,_,_) = not (lowercase form `Map.member` dict) + 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 + + +getContents :: IO String +getContents = hSetBinaryMode stdin True >> UTF8.getContents + +putStr :: String -> IO () +putStr s = hSetBinaryMode stdout True >> UTF8.putStr s + +putStrLn :: String -> IO () +putStrLn s = hSetBinaryMode stdout True >> UTF8.putStrLn s diff --git a/src/GramLab/Perceptron/IntModel.hs b/src/GramLab/Perceptron/IntModel.hs new file mode 100644 --- /dev/null +++ b/src/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 Data.Array.Unboxed + +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 -> 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 ] + examples'' = map swap examples' + labels = map fst examples' + featids = concatMap (map fst . snd) examples' + weights = examples'' == examples'' `seq` P.train (realToFrac $ rate s) + (iter s) + (lo,hi) + yss + $ examples'' + model = IntModel { modelLabels = IntSet.fromList labels + , 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/src/GramLab/Perceptron/Model.hs b/src/GramLab/Perceptron/Model.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Perceptron/Model.hs @@ -0,0 +1,184 @@ +{-# 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 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 +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 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)) + 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/src/GramLab/Perceptron/Multiclass.hs b/src/GramLab/Perceptron/Multiclass.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Perceptron/Multiclass.hs @@ -0,0 +1,171 @@ +{-# 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 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) +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' :: (Float, DenseVector (Y,I), DenseVector (Y,I)) + -> [Y] + -> X + -> Y +decode' w ys x = snd . maximum + $ [ (w`dot'`phi x y,y) | 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 + -> 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 + let ((_,lo),(_,hi)) = A.bounds yss + ys = [lo..hi] + for_ (zip [0..] ss) $ \ (i,(x,y)) -> do + params' <- unsafeFreeze params + 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 + 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 :: Float + -> Int + -> ((Y,I), (Y,I)) + -> A.UArray (Int,Int) Bool + -> [(X, Y)] + -> Model +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) + 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 + $ 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/src/GramLab/Perceptron/Vector.hs b/src/GramLab/Perceptron/Vector.hs new file mode 100644 --- /dev/null +++ b/src/GramLab/Perceptron/Vector.hs @@ -0,0 +1,74 @@ +{-# 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' :: (Float,DenseVector (Int,Int),DenseVector (Int,Int)) + -> ([(Int,Float)],Int) + -> 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) + -> ([(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/src/GramLab/Utils.hs b/src/GramLab/Utils.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Lemma.hs b/src/Lemma.hs new file mode 100644 --- /dev/null +++ b/src/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 (show . make w . fst) $ 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/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,16 @@ + +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 = 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/src/POS.hs b/src/POS.hs new file mode 100644 --- /dev/null +++ b/src/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 snd $ Map.findWithDefault [] w (dictLex global) + getpos Nothing = "" + getpos (Just (Str form:Str label:_)) = head (splitPOS (lang global) label)