diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/delta-h.cabal b/delta-h.cabal --- a/delta-h.cabal +++ b/delta-h.cabal @@ -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 diff --git a/src/Entropy/Algorithm.hs b/src/Entropy/Algorithm.hs --- a/src/Entropy/Algorithm.hs +++ b/src/Entropy/Algorithm.hs @@ -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 diff --git a/src/EvalSem.hs b/src/EvalSem.hs new file mode 100644 --- /dev/null +++ b/src/EvalSem.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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