packages feed

nerf 0.4.0 → 0.5.0

raw patch · 6 files changed

+825/−46 lines, 6 filesdep +bytestringdep +directorydep +filepathdep ~polysoup

Dependencies added: bytestring, directory, filepath, mtl, network, tagsoup, temporary

Dependency ranges changed: polysoup

Files

nerf.cabal view
@@ -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
+ src/NLP/Nerf/Compare.hs view
@@ -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
+ src/NLP/Nerf/Server.hs view
@@ -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
src/NLP/Nerf/Tokenize.hs view
@@ -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
+ src/NLP/Nerf/XCES.hs view
@@ -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)
tools/nerf.hs view
@@ -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 "<all>" (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)