GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

The training script for the PennTreebank is updated to compute more statistics

Browse Source
This commit is contained in:
kr.angelov
2012-09-07 08:18:11 +00:00
parent cd3cca4aa2
commit 93220a2d87
1 changed files with 42 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

53
examples/PennTreebank/training.hs
View File

@@ -5,12 +5,23 @@ import Data.List
main = do
pgf <- readPGF "ParseEngAbs.pgf"
ls <- fmap lines $ readFile "log.txt"
let stats = foldl' (collectStats pgf)
(initStats pgf)
ls <- fmap (filterExprs . lines) $ readFile "log3.txt"
putStrLn ""
putStrLn ("trees: "++show (length ls))
let stats = foldl' (collectStats pgf)
(initStats pgf)
[(fromMaybe (error l) (readExpr (toQ l)),Just (mkCId "Phr"),Nothing) | l <- ls]
mapM_ putStrLn [show f ++ "\t" ++ show p | (f,p) <- uprobs pgf stats]
mapM_ putStrLn [show cat1 ++ "\t" ++ show cat2 ++ "\t" ++ show p | (cat1,cat2,p) <- bprobs pgf stats]
putStrLn ("coverage: "++show (coverage stats))
putStrLn ("Writing ParseEngAbs.probs...")
writeFile "ParseEngAbs.probs" (unlines [show f ++ "\t" ++ show p | (f,p) <- uprobs pgf stats])
putStrLn ("Writing ParseEngAbs2.probs...")
writeFile "ParseEngAbs2.probs" (unlines [show cat1 ++ "\t" ++ show cat2 ++ "\t" ++ show p | (cat1,cat2,p) <- bprobs pgf stats])
putStrLn ("Writing global.probs...")
writeFile "global.probs" (unlines [show f ++ "\t" ++ show p | (f,p) <- gprobs pgf stats])
where
toQ [] = []
toQ ('[':cs) = let (xs,']':ys) = break (==']') cs
@@ -18,29 +29,38 @@ main = do
toQ ('?':cs) = 'Q' : toQ cs
toQ (c:cs) = c : toQ cs
filterExprs [] = []
filterExprs (l:ls)
| null l = filterExprs ls
| elem (head l) "+#*" = drop 2 l : filterExprs ls
| otherwise = filterExprs ls
initStats pgf =
(Map.fromListWith (+)
([(f,1) | f <- functions pgf] ++
[(cat pgf f,1) | f <- functions pgf])
,Map.empty
,0
)
collectStats pgf (ustats,bstats) (e,mb_cat1,mb_cat2) =
collectStats pgf (ustats,bstats,count) (e,mb_cat1,mb_cat2) =
case unApp e of
Just (f,args) -> let fcat = fromMaybe (cat2 pgf f e) mb_cat1
cf = fromMaybe 0 (Map.lookup f ustats)
cc = fromMaybe 0 (Map.lookup fcat ustats)
in cf `seq` cc `seq` bstats `seq`
in cf `seq` cc `seq` bstats `seq` count `seq`
foldl' (collectStats pgf)
(Map.insert f (cf+1) (Map.insert fcat (cc+1) ustats)
,(if null args
then Map.insertWith (+) (fcat,wildCId) 1
else id)
(maybe bstats (\cat2 -> Map.insertWith (+) (cat2,fcat) 1 bstats) mb_cat2)
,count+1
)
(zip3 args (argCats f) (repeat (Just fcat)))
Nothing -> (ustats,bstats)
Nothing -> case unStr e of
Just _ -> (ustats,bstats,count+1)
Nothing -> error ("collectStats ("++show e++")")
where
argCats f =
case fmap unType (functionType pgf f) of
@@ -48,7 +68,11 @@ collectStats pgf (ustats,bstats) (e,mb_cat1,mb_cat2) =
in map tyCat arg_tys
Nothing -> repeat Nothing
uprobs pgf (ustats,bstats) =
coverage (ustats,bstats,count) =
let c = fromMaybe 0 (Map.lookup (mkCId "Q") ustats)
in (fromIntegral (count - c) / fromIntegral count) * 100
uprobs pgf (ustats,bstats,count) =
[toProb f (cat pgf f) | f <- functions pgf]
where
toProb f cat =
@@ -56,7 +80,7 @@ uprobs pgf (ustats,bstats) =
cat_mass = fromMaybe 0 (Map.lookup cat ustats)
in (f, fromIntegral count / fromIntegral cat_mass :: Double)
bprobs pgf (ustats,bstats) =
bprobs pgf (ustats,bstats,count) =
concat [toProb cat | cat <- categories pgf]
where
toProb cat =
@@ -64,6 +88,13 @@ bprobs pgf (ustats,bstats) =
in [(cat1,cat2,fromIntegral count / fromIntegral mass)
| ((cat1,cat2),count) <- Map.toList bstats, cat1==cat]
gprobs pgf (ustats,bstats,count) =
sortBy (\x y -> compare (snd y) (snd x)) [toProb f | f <- functions pgf]
where
toProb f =
let fcount = fromMaybe 0 (Map.lookup f ustats)
in (f, fromIntegral fcount / fromIntegral count :: Double)
cat pgf f =
case fmap unType (functionType pgf f) of
Just (_,cat,_) -> cat
@@ -72,4 +103,4 @@ cat pgf f =
cat2 pgf f e =
case fmap unType (functionType pgf f) of
Just (_,cat,_) -> cat
Nothing -> error ("Unknown function "++showCId f++show e)
Nothing -> error ("Unknown function "++showCId f++" "++show e)