delta-h 0.0.2 → 0.0.3
raw patch · 5 files changed
+151/−22 lines, 5 filesdep ~monad-atomPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: monad-atom
API changes (from Hackage documentation)
+ Entropy.Algorithm: clusterBeam :: Int -> Bool -> ClusterSet (Int, String) -> [X (Int, String)] -> ClusterSet (Int, String)
Files
- README +14/−0
- delta-h.cabal +4/−4
- src/Entropy/Algorithm.hs +25/−10
- src/EvalSem.hs +92/−0
- src/Main.hs +16/−8
README view
@@ -50,6 +50,20 @@ The first argument specifies whether to marginalize over all cluster assignments, the second whether to output detailed information. +The semantic property prediction task can be run with the eval-sem command:+> ./bin/delta-h eval-sem False data/lexicon TRAIN.pos TRAIN.cluster \+ TEST.pos TEST.cluster++The meaning of the arguments to this command:+ False - do not produce verbose output+ data/lexicon - semantic property lexicon file (generated from Wordnet)+ TRAIN.pos - POS tagged train data+ TRAIN.cluster - train data labeled with cluster IDs (use the label command to + generate it)+ TEST.pos - POS tagged test data+ TEST.cluster - test data labeled with cluster IDs (use the label command to + generate it)+ = SOURCES There are some other (currently undocumented) commands: inspect src/Main.hs
delta-h.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.0.2+Version: 0.0.3 -- A short (one-line) description of the package. Synopsis: Online entropy-based model of lexical category acquisition.@@ -53,12 +53,12 @@ Library Exposed-modules: Entropy.Algorithm, Entropy.Features, Reader, ListZipper -- Packages needed in order to build this package.- Build-depends: nlp-scores, monad-atom, binary, text, containers, + Build-depends: nlp-scores, monad-atom >= 0.4 , binary, text, containers, bytestring, base >= 3 && < 5 -- Modules not exported by this package.- Other-modules: Counts, SparseVector, Utils+ Other-modules: Counts, SparseVector, Utils, EvalSem Hs-source-dirs: src @@ -74,7 +74,7 @@ base >= 3 && < 5 -- Modules not exported by this package.- Other-modules: Counts, SparseVector, Utils+ Other-modules: Counts, SparseVector, Utils, EvalSem Hs-source-dirs: src
src/Entropy/Algorithm.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction , BangPatterns #-} module Entropy.Algorithm ( cluster+ , clusterBeam , clusterToken , labelToken , clusterWords@@ -154,23 +155,25 @@ -> ClusterSet (Int,String) -> X (Int,String) -> [(Y,ClusterSet (Int,String))]-clusterToken freeze cs x = - - let rs'@(((e,_),(y,_)):_) = - sortBy - (comparing (\((s,y),_) - -> (realToFrac s::Float, negate y))) +clusterToken freeze cs x = map snd . clusterTok freeze cs $ x++clusterTok :: Bool + -> ClusterSet (Int,String) + -> X (Int,String)+ -> [((Double,Y), (Y,ClusterSet (Int,String)))]+clusterTok freeze cs x =+ let rs = rank $ [let cs' = update cs x y in ((score cs',y),(y,cs')) | y <- nextID cs : ids cs-- , y == nextID cs || Map.size (countXY cs ! y `Map.intersection` x) > 0 ]- rs = map snd rs'- in rs+ in rs +rank :: [((Double,Y),a)] -> [((Double,Y),a)]+rank = sortBy (comparing (\((s,y),_) -> (realToFrac s :: Float, negate y)))+ -- | labelToken: output a single label (from a closed set) labelToken :: ClusterSet (Int,String) -> X (Int,String)@@ -216,6 +219,18 @@ -> ClusterSet (Int, String) cluster freeze = foldl' (\cs x -> snd . head . clusterToken freeze cs $ x) +clusterBeam :: Int + -> Bool + -> ClusterSet (Int,String)+ -> [X (Int, String)] + -> ClusterSet (Int,String)+clusterBeam sz freeze cs = + let step css x = map (snd . snd)+ . take sz+ . rank + . concat + $ [ take sz . clusterTok freeze cs $ x | cs <- css ]+ in head . foldl' step (return cs) normalize :: (Ord k) => Map.Map k Double -> Map.Map k Double normalize x = let s = Map.fold (+) 0 x in Map.map (/s) x
+ src/EvalSem.hs view
@@ -0,0 +1,92 @@+module EvalSem + (evalSem)+where+import qualified Data.Map as Map+import qualified Data.Set as Set++import Reader (readcorpus,Token)+import Data.List (foldl',inits,isPrefixOf,sortBy)+import Data.Ord (comparing)+import SparseVector (plus,scale)+import Utils (splitOn)+import Data.Char (toLower)+import System.Environment +import System.IO (stderr,hPutStr)+import Control.Exception (assert)+import Text.Printf+import NLP.Scores (avgPrecision, mean)++import Debug.Trace+++type Word = String+type POS = String+type ClustID = String+type Feat = String+type Count = Double+type SemLex = Map.Map (Word,POS) (Map.Map Feat Count)+type SemClust = Map.Map ClustID [(Feat,Count)]++parseEntry :: String -> ((Word,POS),Map.Map Feat Count)+parseEntry ln = case words ln of + (wp:fs) -> + let [w,p] = splitOn ':' wp+ in ((w,map toLower p),Map.fromList . map (\f -> (f,1)) + . splitOn ',' + . unwords+ $ fs)++parseLexicon :: String -> SemLex+parseLexicon = foldl' f Map.empty+ . map parseEntry+ . filter (not . null)+ . lines+ where f z (k,v) = Map.insertWith' (Map.unionWith (+)) (v == v `seq` k) v z++semClusters :: SemLex -> [((Word,ClustID,POS),Count)] -> SemClust+semClusters dict = + Map.map (sortBy (flip $ comparing snd)+ . Map.toList)+ . Map.fromListWith (plus) + . map (\((w,cid,p),c) -> + (cid,Map.findWithDefault Map.empty (w,p) dict `scale` c))++ +evalSem args = do+ let [details -- be verbose+ ,lexf -- lexicon file+ ,trainposf -- POS tagged train file+ ,trainf -- Cluster labeled train file+ ,posf -- POS tagged test file+ ,clustf -- Cluster labeled test file+ ] = args+ lex <- fmap parseLexicon $ readFile lexf+ css <- fmap readcorpus $ readFile trainf+ cpos <- fmap readcorpus $ readFile trainposf+ pss <- fmap readcorpus $ readFile posf+ xss <- fmap readcorpus $ readFile clustf+ let toks yss zss = Map.toList + . Map.fromListWith (+)+ . map (\k -> (k,1))+ . zipWith (\(w,p) (w',cid) -> assert (w == w') (w,cid,p)) + (concat yss)+ . concat + $ zss+ its = filter (\((w,_,p),_) -> + (take 1 p `elem` ["n","v"] && Map.member (w,p) lex))+ . toks pss+ $ xss+ cs = semClusters lex . toks cpos $ css + ap ((w,cid,p),c) | read details && + trace (show $ Map.findWithDefault [] cid $ cs) False =+ undefined+ ap ((w,cid,p),c) = c * (avgPrecision (Map.keysSet + . Map.findWithDefault Map.empty (w,p)+ $ lex)+ . map fst+ . Map.findWithDefault [] cid + $ cs)+ aps = map ap $ its :: [Double]+ hPutStr stderr . unlines . map (\(t,a) -> printf "%-40s %2.3f" (show t) a)+ . zip its $ aps+ printf "%2.3f\n" . (/ sum (map snd its)) . sum $ aps
src/Main.hs view
@@ -18,6 +18,7 @@ import Data.List (sortBy,foldl') import Data.Ord (comparing) import Counts (counts,vi,ari)+import EvalSem (evalSem) import qualified Data.Text.Lazy as Text type Txt = Text.Text@@ -25,13 +26,10 @@ main = do (command:args) <- getArgs case command of- "learn" -> do let (fids:trainf:_) = args- train <- fmap readcorpus $ readFile trainf- let xss = concat . examples (read fids) $ train- cs = cluster False empty xss- hPutStrLn stderr . show . Map.size . countXY $ cs- B.writeFile (trainf ++ "." ++ fids ++ ".learn.model") - . encode $ cs+ "learn" -> learn cluster args+ "learn-beam" -> do + let (k:args') = args + learn (clusterBeam (read k)) args' "learn-seeded" -> do let (n:m:seedf:trainf:_) = args seed' <- fmap decode $ B.readFile seedf@@ -186,8 +184,18 @@ let cs = counts . zip gold $ test printf "VI: %.4f\n" . vi $ cs printf "ARI: %.4f\n" . ari $ cs+ "eval-sem" -> evalSem args+ +learn f args = do + let (fids:trainf:_) = args+ train <- fmap readcorpus $ readFile trainf+ let xss = concat . examples (read fids) $ train+ cs = f False empty xss+ hPutStrLn stderr . show . Map.size . countXY $ cs+ B.writeFile (trainf ++ "." ++ fids ++ ".learn.model") + . encode $ cs -teach :: [Int] -> [[Token]] -> (ClusterSet (Int,String),Atom.AtomTable)+teach :: [Int] -> [[Token]] -> (ClusterSet (Int,String),Atom.AtomTable String) teach fids train = flip Atom.runAtom Atom.empty $ do fmap (makeClusterSet . foldl' (\ z (!k,!x) -> Map.insertWith' plus k x z) Map.empty