diff --git a/nerf.cabal b/nerf.cabal --- a/nerf.cabal +++ b/nerf.cabal @@ -1,5 +1,5 @@ name: nerf -version: 0.4.0 +version: 0.5.0 synopsis: Nerf, the named entity recognition tool based on linear-chain CRFs description: The package provides the named entity recognition (NER) tool divided into a @@ -29,20 +29,24 @@ hs-source-dirs: src build-depends: - base >= 4 && < 5 + base >= 4 && < 5 , containers , vector , text , binary - , text-binary >= 0.1 && < 0.2 - , polysoup >= 0.1 && < 0.2 - , crf-chain1 >= 0.2 && < 0.3 - , data-named >= 0.5.1 && < 0.6 - , monad-ox >= 0.2 && < 0.3 - , sgd >= 0.2.1 && < 0.3 - , polimorf >= 0.6.0 && < 0.7 - , dawg >= 0.8.1 && < 0.9 - , tokenize == 0.1.3 + , bytestring >= 0.9 && < 0.10 + , text-binary >= 0.1 && < 0.2 + , tagsoup >= 0.13 && < 0.14 + , polysoup >= 0.2 && < 0.3 + , crf-chain1 >= 0.2 && < 0.3 + , data-named >= 0.5.1 && < 0.6 + , monad-ox >= 0.2 && < 0.3 + , sgd >= 0.2.1 && < 0.3 + , polimorf >= 0.6.0 && < 0.7 + , dawg >= 0.8.1 && < 0.9 + , tokenize == 0.1.3 + , mtl >= 2.1 && < 2.2 + , network >= 2.3 && < 2.4 , cmdargs exposed-modules: @@ -56,6 +60,9 @@ , NLP.Nerf.Dict.PNET , NLP.Nerf.Dict.NELexicon , NLP.Nerf.Dict.Prolexbase + , NLP.Nerf.Compare + , NLP.Nerf.Server + , NLP.Nerf.XCES ghc-options: -Wall -O2 @@ -65,5 +72,9 @@ executable nerf hs-source-dirs: src, tools + build-depends: + filepath >= 1.3 && < 1.4, + directory >= 1.2 && < 1.3, + temporary >= 1.1 && < 1.2 main-is: nerf.hs ghc-options: -Wall -O2 -threaded -rtsopts diff --git a/src/NLP/Nerf/Compare.hs b/src/NLP/Nerf/Compare.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Nerf/Compare.hs @@ -0,0 +1,119 @@ +-- | Compare two NE-annotated datasets. + + +module NLP.Nerf.Compare +( Stats (..) +, (.+.) +, compare +) where + + +import Prelude hiding (span, compare) +import Control.Applicative ((<$>)) +import Control.Monad (forM) +import qualified Control.Monad.State.Strict as ST +import qualified Control.Monad.Writer.Strict as W +import qualified Data.Traversable as Tr +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Char as C +import qualified Data.Text as T + +import qualified Data.Named.Tree as N + + +-- | Statistics. +data Stats = Stats + { fp :: !Int -- ^ false positive + , tp :: !Int -- ^ true positive + , fn :: !Int -- ^ false negative + , tn :: !Int -- ^ true negative + } deriving (Show, Eq, Ord) + + +-- | A NE represented by its label and a character-level span, over which +-- the NE is stretched. White-space characters do not count when computing +-- the span. +data Node a = Node + { label :: a + , _span :: (Int, Int) + } deriving (Show, Eq, Ord) + + +-- | A union of two spans. +spanUnion :: (Int, Int) -> (Int, Int) -> (Int, Int) +spanUnion (p0, q0) (p1, q1) = (min p0 p1, max q0 q1) + + +-- | Add stats. +(.+.) :: Stats -> Stats -> Stats +x .+. y = Stats + { fp = fp x + fp y + , tp = tp x + tp y + , fn = fn x + fn y + , tn = tn x + tn y } + + +-- | Compare two NE-annotated datasets. The function assumes, that +-- forest pairs correspond to the same sentences. +compare + :: Ord a + => [ ( N.NeForest a T.Text + , N.NeForest a T.Text) ] + -> M.Map a Stats +compare xs = M.unionsWith (.+.) + [ cmpNodes (nodesF $ toIDs x) (nodesF $ toIDs y) + | (x, y) <- xs ] + + +-- | Compare two sets of `Node`s. The function is label-sensitive. +cmpNodes :: Ord a => S.Set (Node a) -> S.Set (Node a) -> M.Map a Stats +cmpNodes x y = M.fromList + [ (key, mkStats (with key x) (with key y)) + | key <- S.toList keys ] + where + keys = S.union (getKeys x) (getKeys y) + getKeys = S.fromList . map label . S.toList + with k = S.filter ((==k).label) + + +-- | Compare two sets of `Node`s. The function is label-insensitive. +mkStats :: Ord a => S.Set (Node a) -> S.Set (Node a) -> Stats +mkStats x y = Stats + { fp = S.size (S.difference y x) + , tp = S.size (S.intersection x y) + , fn = S.size (S.difference x y) + , tn = 0 } + + +-- | Replace words with character-level position identifiers. +-- White-spaces are ignored. +toIDs :: N.NeForest a T.Text -> N.NeForest a (Int, Int) +toIDs ts = flip ST.evalState 0 $ forM ts $ Tr.mapM $ \e -> case e of + Left x -> return (Left x) + Right x -> do + let k = T.length $ T.filter (not.C.isSpace) x + i <- ST.get + ST.put $ i + k + return $ Right (i, i + k) + + +-- | Extract the set of nodes from the NE forest. +nodesF :: Ord a => N.NeForest a (Int, Int) -> S.Set (Node a) +nodesF = S.unions . map nodesT + + +-- | Extract the set of nodes from the NE tree. +nodesT :: Ord a => N.NeTree a (Int, Int) -> S.Set (Node a) +nodesT = W.execWriter . mkNode + + +-- | Make `Node` from a tree. Return the span of the tree. +mkNode + :: Ord a => N.NeTree a (Int, Int) + -> W.Writer (S.Set (Node a)) (Int, Int) +mkNode (N.Node (Right i) _) = return i +mkNode (N.Node (Left neType) xs) = do + span <- foldl1 spanUnion <$> mapM mkNode xs + W.tell $ S.singleton $ Node neType span + return span diff --git a/src/NLP/Nerf/Server.hs b/src/NLP/Nerf/Server.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Nerf/Server.hs @@ -0,0 +1,92 @@ +module NLP.Nerf.Server +( +-- * Server + runNerfServer + +-- * Client +, ner +) where + + +import Control.Applicative ((<$>)) +import Control.Monad (forever, void) +import Control.Concurrent (forkIO) +import System.IO (Handle, hFlush) +import qualified Data.Binary as B +import qualified Data.ByteString.Lazy as BS +import qualified Network as N + +import Data.Named.Tree (NeForest) +import NLP.Nerf.Types +import NLP.Nerf (Nerf) +import qualified NLP.Nerf as Nerf + + +------------------------------------------------- +-- Server +------------------------------------------------- + + +-- | Run a Nerf server on a given port. +runNerfServer :: Nerf -> N.PortID -> IO () +runNerfServer nerf port = N.withSocketsDo $ do + sock <- N.listenOn port + forever $ sockHandler nerf sock + + +sockHandler :: Nerf -> N.Socket -> IO () +sockHandler nerf sock = do + (handle, _, _) <- N.accept sock + -- putStrLn "Connection established" + void $ forkIO $ do + -- putStrLn "Waiting for input..." + inp <- recvMsg handle + -- putStr "> " >> T.putStrLn inp + let out = Nerf.ner nerf inp + -- putStr "No. of sentences: " >> print (length out) + sendMsg handle out + + +------------------------------------------------- +-- Client +------------------------------------------------- + + +-- | Perform NER tagging on the input sentence. +ner :: N.HostName -> N.PortID -> String -> IO (NeForest NE Word) +ner host port inp = do + handle <- N.connectTo host port + -- putStrLn "Connection established" + -- putStr "Send request: " >> putStrLn inp + sendMsg handle inp + recvMsg handle + + +------------------------------------------------- +-- Messages +------------------------------------------------- + + +sendMsg :: B.Binary a => Handle -> a -> IO () +sendMsg h msg = do + let x = B.encode msg + n = fromIntegral $ BS.length x + sendInt h n + BS.hPut h x + hFlush h + + +recvMsg :: B.Binary a => Handle -> IO a +recvMsg h = do + n <- recvInt h + B.decode <$> BS.hGet h n + + +sendInt :: Handle -> Int -> IO () +sendInt h x = BS.hPut h (B.encode x) + + +-- | TODO: is it safe to assume that the length of the +-- `Int` representation is 8? +recvInt :: Handle -> IO Int +recvInt h = B.decode <$> BS.hGet h 8 diff --git a/src/NLP/Nerf/Tokenize.hs b/src/NLP/Nerf/Tokenize.hs --- a/src/NLP/Nerf/Tokenize.hs +++ b/src/NLP/Nerf/Tokenize.hs @@ -44,7 +44,7 @@ -- Synchronizing named entities with new sentence tokenization. --------------------------------------------------------------- --- | A class of objects with size. +-- | A class of objects which can be converted to `String`. class Word a where word :: a -> String diff --git a/src/NLP/Nerf/XCES.hs b/src/NLP/Nerf/XCES.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Nerf/XCES.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +-- | Support for the XCES format. + + +module NLP.Nerf.XCES +( nerXCES +) where + + +import qualified Data.Text.Lazy as L +import Data.List (intercalate, intersperse) +import Data.Char (isSpace) +import Text.HTML.TagSoup ((~==)) +import qualified Text.HTML.TagSoup as S +import Text.XML.PolySoup hiding (Parser) + +import Data.Named.Tree +import NLP.Nerf.Types +import qualified NLP.Nerf.Tokenize as Tok + + +--------------------------------------------------------------------- +-- Core types +--------------------------------------------------------------------- + + +-- | An XML tag. +type Tag = S.Tag L.Text + + +-- | An XML parser. +type Parser a = XmlParser L.Text a + + +--------------------------------------------------------------------- +-- XML tags +--------------------------------------------------------------------- + + +-- | A sentence opening tag. +sentOpen :: Tag +sentOpen = S.TagOpen "chunk" [("type", "s")] + + +-- | A sentence opening tag. +sentClose :: Tag +sentClose = S.TagClose "chunk" + + +-- | A sentence opening tag. +tokOpen :: Tag +tokOpen = S.TagOpen "tok" [] + + +-- -- | A sentence opening tag. +-- tokClose :: Tag +-- tokClose = S.TagClose "tok" + + +-- | A sentence opening tag. +nsOpen :: Tag +nsOpen = S.TagOpen "ns" [] + + +--------------------------------------------------------------------- +-- XML chunking +--------------------------------------------------------------------- + + +-- | Group tags corresponding to individual sentences as right elements. +chunk :: [Tag] -> [Either Tag [Tag]] +chunk (x:xs) + | x ~== sentOpen = + let (sent, rest) = takeSent xs + in Right (x:sent) : chunk rest + | otherwise = Left x : chunk xs +chunk [] = [] + + +-- | Take tags starting with a sentence. +takeSent :: [Tag] -> ([Tag], [Tag]) +takeSent = go [] where + go acc (x:xs) + | x == sentClose = (reverse $ x:acc, xs) + | otherwise = go (x:acc) xs + go _ [] = error "takeSent: expected sentence closing tag" + + +-- | Remove division into chunks. +unChunk :: [Either Tag [Tag]] -> [Tag] +unChunk = concatMap $ either (:[]) id + + +--------------------------------------------------------------------- +-- XML sentence intermediate +--------------------------------------------------------------------- + + +-- | Intermediate sentence representation. The ending tag is not preserved +-- since it is always the same. It should be remembered during the sentence +-- rendering process. +data SentI = SentI { + -- | Beginning tag. + sentBegI :: Tag + -- | Sentence contents. + , sentConI :: [(SegT, XmlTree)] + } deriving (Show) + + +-- | Type of a sentence sub-element. +data SegT = TokT | NsT | OtherT deriving (Show) + + +-- | Identify type of a sub-tree. +idTreeT :: XmlTree -> SegT +idTreeT (Node x _) + | x ~== tokOpen = TokT + | x ~== nsOpen = NsT + | otherwise = OtherT + + +-- | XML intermediate sentence parser. +sentIP :: Parser SentI +sentIP = + begP >^> \x -> SentI x <$> many elemP + where + begP = tag "chunk" *> hasAttr "type" "s" *> getTag + elemP = (\x -> (idTreeT x, x)) <$> xmlTreeP + + +--------------------------------------------------------------------- +-- XML sentence +--------------------------------------------------------------------- + + +-- | An XML sentence. The ending tag is not preserved since it is always +-- the same. It should be remembered during the sentence rendering process. +data Sent t = Sent { + -- | Beginning tag of a sentence. + sentBeg :: Tag + -- | Contents of a sentence. + , sentCon :: t Tok + -- | Additional, non-token tags, placed after the last token + , sentAdd :: [XmlTree] } + + +-- | Translate sentence into its final representation. +joinSent :: SentI -> Sent [] +joinSent SentI{..} = + uncurry (Sent sentBegI) (go [] [] False sentConI) + where + -- TODO: could we represent this function as a fold? + go acc res hasNs ((typ, tagTree) : xs) = case typ of + TokT -> + let tok = Tok + { orth = tagsParseXml tokOrthP (enumTree tagTree) + , nps = hasNs + , tagsIn = tagTree + , tagsBf = reverse acc } + in go [] (tok:res) False xs + NsT -> go (tagTree:acc) res True xs + OtherT -> go (tagTree:acc) res hasNs xs + go acc res _ [] = (reverse res, reverse acc) + + +-- | Parse a list of tags into a sentence. +parseSent :: [Tag] -> Sent [] +parseSent = joinSent . tagsParseXml sentIP + + +--------------------------------------------------------------------- +-- Annotated XML sentence +--------------------------------------------------------------------- + + +-- | List of a elements annotated with NEs. +newtype Ann a = Ann { unAnn :: NeForest NE a } + + +-- | A sentence opening tag. +neOpen :: NE -> Tag +neOpen x = S.TagOpen "group" [("type", L.fromStrict x)] + + +-- | A sentence opening tag. +neClose :: Tag +neClose = S.TagClose "group" + + +-- | Render an annotated sentence. +renderAnnSent :: Sent Ann -> [Tag] +renderAnnSent Sent{..} = between + [sentBeg, newline] + [newline, sentClose] + ( interMap renderNeTree (unAnn sentCon) ) + -- TODO: ponizej nie intersperse, trzeba dodac newline + -- przed kazdym elementem. + -- ++ intersperse newline (concatMap enumTree sentAdd) ) + + +-- | Render an element of an annotated sentence. +renderNeTree :: NeTree NE Tok -> [Tag] +renderNeTree (Node (Left v) xs) + = between + [neOpen v, newline] + [newline, neClose] + $ interMap renderNeTree xs +renderNeTree (Node (Right t) _) = renderTok t + + +--------------------------------------------------------------------- +-- XML Token +--------------------------------------------------------------------- + + +-- | An XML token. +data Tok = Tok + { orth :: L.Text -- ^ Orthographic form + , nps :: Bool -- ^ No preceding space + , tagsIn :: XmlTree -- ^ Token tags + , tagsBf :: [XmlTree] -- ^ Non-token tags before the token + } + + +instance Tok.Word Tok where + word = Tok.word . orth + + +tokOrthP :: Parser L.Text +tokOrthP = maybe "" id <$> (tag "tok" ^> findIgnore (tag "orth" ^> text)) + + +-- | Render token. +renderTok :: Tok -> [Tag] +renderTok Tok{..} = case before of + [] -> inside + _ -> intercalate [newline] [before, inside] + where + before = interMap enumTree tagsBf + inside = + let Node v xs = tagsIn + in between [v, newline] [newline, endFrom v] + (interMap enumTree xs) + + + + +--------------------------------------------------------------------- +-- XML generic +--------------------------------------------------------------------- + + +-- | A parsed XML tree. In nodes the content/opening tags are preserved. +type XmlTree = Tree Tag + + +-- | Parse tags to an XML tree representation. +xmlTreeP :: Parser XmlTree +xmlTreeP = + let commTag = satisfyPred ((,) <$> getTag <*> isTagComment) + textTag = satisfyPred ((,) <$> getTag <*> isTagText) + leafTag = fst <$> (textTag <|> commTag) + in trueXmlTreeP <|> (Node <$> leafTag <*> pure []) + + +trueXmlTreeP :: Parser XmlTree +trueXmlTreeP = do + (beg, name) <- satisfyPred ((,) <$> getTag <*> tagOpenName) + subForest <- beg `seq` name `seq` many xmlTreeP + satisfyPred $ isTagCloseName name + return $ Node beg subForest + + +-- | Enumerate tags present in the tree. +enumTree :: XmlTree -> [Tag] +enumTree (Node v xs) = if S.isTagOpen v + then v : concatMap enumTree xs ++ [endFrom v] + else [v] + + +--------------------------------------------------------------------- +-- Misc +--------------------------------------------------------------------- + + +-- | Put the list between the two elements. +between :: [a] -> [a] -> [a] -> [a] +between p q xs = p ++ xs ++ q + + +-- | A newline tag. +newline :: Tag +newline = S.TagText "\n" + + +-- | Make closing tag from the opening tag. +endFrom :: Tag -> Tag +endFrom (S.TagOpen x _) = S.TagClose x +endFrom _ = error "endFrom: not an opening tag" + + +-- | Map and intercalate with newlines. +interMap :: (a -> [Tag]) -> [a] -> [Tag] +interMap f = intercalate [newline] . map f + + +--------------------------------------------------------------------- +-- NER +--------------------------------------------------------------------- + + +-- | Annotate XCES (in a form of a tag list) with NEs with respect +-- to the given NER function. +-- nerXCES :: Nerf.Nerf -> L.Text -> L.Text +nerXCES :: (String -> NeForest NE Word) -> L.Text -> L.Text +nerXCES nerFun + = S.renderTagsOptions opts + . unChunk + . intersperse (Left newline) + . mapR + ( renderAnnSent + . nerSent nerFun + . parseSent ) + . chunk + . filter relevant + . S.parseTags + where + opts = S.renderOptions {S.optMinimize = const True} + mapR = map . fmap + relevant (S.TagWarning _) = False + relevant (S.TagPosition _ _) = False + relevant (S.TagText x) = not $ L.all isSpace x + relevant _ = True + + +-- | Annotate XCES sentence with NEs. +-- nerSent :: Nerf.Nerf -> Sent [] -> Sent Ann +nerSent :: (String -> NeForest NE Word) -> Sent [] -> Sent Ann +nerSent nerFun s@Sent{..} = s + { sentCon = Ann $ Tok.moveNEs + (nerFun $ restoreOrigSent sentCon) + sentCon } + + +-- | Restore original sentence. +restoreOrigSent :: [Tok] -> String +restoreOrigSent + = dropWhile isSpace + . concatMap tokStr + where + tokStr Tok{..} = (if nps then "" else " ") ++ (L.unpack orth) diff --git a/tools/nerf.hs b/tools/nerf.hs --- a/tools/nerf.hs +++ b/tools/nerf.hs @@ -3,31 +3,63 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -import System.Console.CmdArgs -import System.IO +import System.Console.CmdArgs +import System.IO ( Handle, hGetBuffering, hSetBuffering - , stdout, BufferMode (..) ) -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (forM_, when) -import Data.Maybe (catMaybes) -import Data.Binary (encodeFile, decodeFile) -import Data.Text.Binary () -import Text.Named.Enamex (showForest) + , stdout, BufferMode (..), hClose, hFlush ) +import System.IO.Unsafe (unsafePerformIO) +import qualified System.IO.Temp as Temp +import qualified Network as N +import System.Directory (getDirectoryContents) +import System.FilePath (takeBaseName, (), (<.>)) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second) +import Control.Monad (forM_) +import Data.Maybe (catMaybes) +import Data.Binary (encodeFile, decodeFile) +import Data.Text.Binary () +import Text.Named.Enamex (parseEnamex, showForest) +import qualified Data.Foldable as F +import qualified Data.Map as M import qualified Numeric.SGD as SGD +import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.IO as L import qualified Data.DAWG.Static as D -import NLP.Nerf (train, ner, tryOx) -import NLP.Nerf.Schema (defaultConf) -import NLP.Nerf.Dict +import NLP.Nerf (train, ner, tryOx) +import NLP.Nerf.Schema (defaultConf) +import NLP.Nerf.Dict ( extractPoliMorf, extractPNEG, extractNELexicon, extractProlexbase , extractIntTriggers, extractExtTriggers, Dict ) +import NLP.Nerf.XCES as XCES +import qualified NLP.Nerf.Server as S +import NLP.Nerf.Compare ((.+.)) +import qualified NLP.Nerf.Compare as C + + +-- | Default port number. +portDefault :: Int +portDefault = 10090 + + +--------------------------------------- +-- Command line options +--------------------------------------- + + +-- | Data formats. +data Format + = Text + | XCES + deriving (Data, Typeable, Show) + + data Nerf = Train { trainPath :: FilePath - , eval :: Maybe FilePath + , evalPath :: Maybe FilePath , poliMorf :: Maybe FilePath , prolex :: Maybe FilePath , pneg :: Maybe FilePath @@ -38,10 +70,30 @@ , regVar :: Double , gain0 :: Double , tau :: Double - , outNerf :: FilePath } + , outNerf :: Maybe FilePath } + | CV + { dataDir :: FilePath + , poliMorf :: Maybe FilePath + , prolex :: Maybe FilePath + , pneg :: Maybe FilePath + , neLex :: Maybe FilePath + , pnet :: Maybe FilePath + , iterNum :: Double + , batchSize :: Int + , regVar :: Double + , gain0 :: Double + , tau :: Double + , outDir :: Maybe FilePath } | NER - { dataPath :: FilePath - , inNerf :: FilePath } + { inModel :: FilePath + , format :: Format } + | Server + { inModel :: FilePath + , port :: Int } + | Client + { format :: Format + , host :: String + , port :: Int } | Ox { dataPath :: FilePath , poliMorf :: Maybe FilePath @@ -49,12 +101,16 @@ , pneg :: Maybe FilePath , neLex :: Maybe FilePath , pnet :: Maybe FilePath } + | Compare + { dataPath :: FilePath + , dataPath' :: FilePath } deriving (Data, Typeable, Show) + trainMode :: Nerf trainMode = Train { trainPath = def &= argPos 0 &= typ "TRAIN-FILE" - , eval = def &= typFile &= help "Evaluation file" + , evalPath = def &= typFile &= help "Evaluation file" , poliMorf = def &= typFile &= help "Path to PoliMorf" , prolex = def &= typFile &= help "Path to Prolexbase" , pneg = def &= typFile &= help "Path to PNEG-LMF" @@ -65,13 +121,48 @@ , regVar = 10.0 &= help "Regularization variance" , gain0 = 1.0 &= help "Initial gain parameter" , tau = 5.0 &= help "Initial tau parameter" - , outNerf = def &= typFile &= help "Output Nerf file" } + , outNerf = def &= typFile &= help "Output model file" } + +cvMode :: Nerf +cvMode = CV + { dataDir = def &= argPos 0 &= typ "DATA-DIR" + , poliMorf = def &= typFile &= help "Path to PoliMorf" + , prolex = def &= typFile &= help "Path to Prolexbase" + , pneg = def &= typFile &= help "Path to PNEG-LMF" + , neLex = def &= typFile &= help "Path to NELexicon" + , pnet = def &= typFile &= help "Path to PNET" + , iterNum = 10 &= help "Number of SGD iterations" + , batchSize = 30 &= help "Batch size" + , regVar = 10.0 &= help "Regularization variance" + , gain0 = 1.0 &= help "Initial gain parameter" + , tau = 5.0 &= help "Initial tau parameter" + , outDir = def &= typFile &= help "Output model directory" } + + nerMode :: Nerf nerMode = NER - { inNerf = def &= argPos 0 &= typ "NERF-FILE" - , dataPath = def &= argPos 1 &= typ "INPUT" } + { inModel = def &= argPos 0 &= typ "MODEL-FILE" + , format = enum + [ Text &= help "Raw text" + , XCES &= help "XCES" ] } + +serverMode :: Nerf +serverMode = Server + { inModel = def &= argPos 0 &= typ "MODEL-FILE" + , port = portDefault &= help "Port number" } + + +clientMode :: Nerf +clientMode = Client + { port = portDefault &= help "Port number" + , host = "localhost" &= help "Server host name" + , format = enum + [ Text &= help "Raw text" + , XCES &= help "XCES" ] } + + oxMode :: Nerf oxMode = Ox { dataPath = def &= argPos 0 &= typ "DATA-FILE" @@ -81,9 +172,18 @@ , neLex = def &= typFile &= help "Path to NELexicon" , pnet = def &= typFile &= help "Path to PNET" } + +cmpMode :: Nerf +cmpMode = Compare + { dataPath = def &= argPos 0 &= typ "REFERENCE" + , dataPath' = def &= argPos 1 &= typ "COMPARED" } + + argModes :: Mode (CmdArgs Nerf) -argModes = cmdArgsMode $ modes [trainMode, nerMode, oxMode] +argModes = cmdArgsMode $ modes + [trainMode, cvMode, nerMode, serverMode, clientMode, cmpMode, oxMode] + data Resources = Resources { poliDict :: Maybe Dict , prolexDict :: Maybe Dict @@ -92,6 +192,7 @@ , intDict :: Maybe Dict , extDict :: Maybe Dict } + extract :: Nerf -> IO Resources extract nerf = withBuffering stdout NoBuffering $ Resources <$> extractDict "PoliMorf" extractPoliMorf (poliMorf nerf) @@ -101,6 +202,7 @@ <*> extractDict "internal triggers" extractIntTriggers (pnet nerf) <*> extractDict "external triggers" extractExtTriggers (pnet nerf) + withBuffering :: Handle -> BufferMode -> IO a -> IO a withBuffering h mode io = do oldMode <- hGetBuffering h @@ -109,30 +211,34 @@ hSetBuffering h oldMode return x + extractDict :: String -> (a -> IO Dict) -> Maybe a -> IO (Maybe Dict) extractDict msg f (Just x) = do putStr $ "Reading " ++ msg ++ "..." dict <- f x let k = D.numStates dict k `seq` putStrLn $ " Done" - putStrLn $ "Number of automata states = " ++ show k + putStrLn $ "Number of automaton states = " ++ show k return (Just dict) extractDict _ _ Nothing = return Nothing + main :: IO () main = exec =<< cmdArgsRun argModes + exec :: Nerf -> IO () + exec nerfArgs@Train{..} = do Resources{..} <- extract nerfArgs cfg <- defaultConf (catMaybes [poliDict, prolexDict, pnegDict, neLexDict]) intDict extDict - nerf <- train sgdArgs cfg trainPath eval - when (not . null $ outNerf) $ do - putStrLn $ "\nSaving model in " ++ outNerf ++ "..." - encodeFile outNerf nerf + nerf <- train sgdArgs cfg trainPath evalPath + flip F.traverse_ outNerf $ \path -> do + putStrLn $ "\nSaving model in " ++ path ++ "..." + encodeFile path nerf where sgdArgs = SGD.SgdArgs { SGD.batchSize = batchSize @@ -141,13 +247,64 @@ , SGD.gain0 = gain0 , SGD.tau = tau } -exec NER{..} = do - nerf <- decodeFile inNerf - input <- readRaw dataPath - forM_ input $ \sent -> do - let forest = ner nerf (L.unpack sent) - L.putStrLn (showForest forest) +exec nerfArgs@CV{..} = do + Resources{..} <- extract nerfArgs + cfg <- defaultConf + (catMaybes [poliDict, prolexDict, pnegDict, neLexDict]) + intDict extDict + parts <- getParts dataDir + forM_ (enumDivs parts) $ \(evalPath, trainPaths) -> do + putStrLn $ "\nPart: " ++ evalPath + withParts trainPaths $ \trainPath -> do + nerf <- train sgdArgs cfg trainPath (Just evalPath) + flip F.traverse_ outDir $ \dir -> do + let path = dir takeBaseName evalPath <.> ".bin" + putStrLn $ "\nSaving model in " ++ path ++ "..." + encodeFile path nerf + where + sgdArgs = SGD.SgdArgs + { SGD.batchSize = batchSize + , SGD.regVar = regVar + , SGD.iterNum = iterNum + , SGD.gain0 = gain0 + , SGD.tau = tau } + + +exec NER{..} = case format of + Text -> do + nerf <- decodeFile inModel + inp <- L.lines <$> L.getContents + forM_ inp $ \sent -> do + let forest = ner nerf (L.unpack sent) + L.putStrLn (showForest forest) + XCES -> do + nerf <- decodeFile inModel + L.putStrLn . XCES.nerXCES (ner nerf) =<< L.getContents + + +exec Server{..} = do + putStr "Loading model..." >> hFlush stdout + nerf <- decodeFile inModel + nerf `seq` putStrLn " done" + let portNum = N.PortNumber $ fromIntegral port + putStrLn $ "Listening on port " ++ show port + S.runNerfServer nerf portNum + + +exec Client{..} = case format of + Text -> do + inp <- L.lines <$> L.getContents + forM_ inp $ \sent -> do + forest <- S.ner host portNum $ L.unpack sent + L.putStrLn (showForest forest) + XCES -> do + let nerRemote = unsafePerformIO . S.ner host portNum + L.putStrLn . XCES.nerXCES nerRemote =<< L.getContents + where + portNum = N.PortNumber $ fromIntegral port + + exec nerfArgs@Ox{..} = do Resources{..} <- extract nerfArgs cfg <- defaultConf @@ -155,5 +312,51 @@ intDict extDict tryOx cfg dataPath -readRaw :: FilePath -> IO [L.Text] -readRaw = fmap L.lines . L.readFile + +exec Compare{..} = do + x <- parseEnamex <$> L.readFile dataPath + y <- parseEnamex <$> L.readFile dataPath' + let statMap = C.compare $ zip x y + forM_ (M.toList statMap) $ uncurry printStats + printStats "" (foldl1 (.+.) $ M.elems statMap) + where + printStats neType stats = do + putStrLn $ "# " ++ T.unpack neType + putStrLn $ "true positive: " ++ show (C.tp stats) + putStrLn $ "false positive: " ++ show (C.fp stats) + -- putStrLn $ "true negative: " ++ show (C.tn stats) + putStrLn $ "false negative: " ++ show (C.fn stats) + + +-- readRaw :: FilePath -> IO [L.Text] +-- readRaw = fmap L.lines . L.readFile + + +---------------------------------------- +-- Cross-validation +---------------------------------------- + + +-- | Get paths of the individual parts of the dataset +-- stored in the given directory. +getParts :: FilePath -> IO [FilePath] +getParts path = do + xs <- filter (\x -> not (x `elem` [".", ".."])) + <$> getDirectoryContents path + return $ map (path ) xs + + +-- | Take data from the given list of paths and store +-- it all in a temporary file, than run the given handler. +withParts :: [FilePath] -> (FilePath -> IO a) -> IO a +withParts paths handler = Temp.withSystemTempFile "train." $ \tempPath _h -> do + hClose _h + forM_ paths $ \srcPath -> do + L.readFile srcPath >>= L.appendFile tempPath + handler tempPath + + +-- | Enumerate subsequent partitionings of the dataset. +enumDivs :: [a] -> [(a, [a])] +enumDivs [] = [] +enumDivs (x:xs) = (x, xs) : map (second (x:)) (enumDivs xs)