packages feed

nerf 0.1.0 → 0.2.0

raw patch · 8 files changed

+479/−225 lines, 8 filesdep +dawgdep −adictdep ~polimorfdep ~text-binary

Dependencies added: dawg

Dependencies removed: adict

Dependency ranges changed: polimorf, text-binary

Files

NLP/Nerf.hs view
@@ -23,15 +23,15 @@ import qualified Data.CRF.Chain1 as CRF  import NLP.Nerf.Types-import NLP.Nerf.Schema (SchemaCfg, Schema, fromCfg, schematize)+import NLP.Nerf.Schema (SchemaConf, Schema, fromConf, schematize)  -- | A Nerf consists of the observation schema configuration and the CRF model. data Nerf = Nerf-    { schemaCfg :: SchemaCfg-    , crf       :: CRF.CRF Ob Lb }+    { schemaConf    :: SchemaConf+    , crf           :: CRF.CRF Ob Lb }  instance Binary Nerf where-    put Nerf{..} = put schemaCfg >> put crf+    put Nerf{..} = put schemaConf >> put crf     get = Nerf <$> get <*> get  flatten :: Schema a -> Tr.NeForest NE Word -> CRF.SentL Ob Lb@@ -53,20 +53,20 @@     putStrLn ""   -- | Show results of observation extraction on the input ENAMEX file.-tryOx :: SchemaCfg -> FilePath -> IO ()+tryOx :: SchemaConf -> FilePath -> IO () tryOx cfg path = do-    input <- readFlat (fromCfg cfg) path+    input <- readFlat (fromConf cfg) path     mapM_ drawSent input  -- | Train Nerf on the input data using the SGD method. train     :: SgdArgs              -- ^ Args for SGD-    -> SchemaCfg            -- ^ Observation schema configuration+    -> SchemaConf           -- ^ Observation schema configuration     -> FilePath             -- ^ Train data (ENAMEX)     -> Maybe FilePath       -- ^ Maybe eval data (ENAMEX)     -> IO Nerf              -- ^ Nerf with resulting codec and model train sgdArgs cfg trainPath evalPathM = do-    let schema = fromCfg cfg+    let schema = fromConf cfg         readTrain = readFlat schema trainPath         readEvalM = evalPathM >>= \evalPath ->             Just ([], readFlat schema evalPath)@@ -76,6 +76,6 @@ -- | Perform named entity recognition (NER) using the Nerf. ner :: Nerf -> [Word] -> Tr.NeForest NE Word ner nerf ws =-    let schema = fromCfg (schemaCfg nerf)+    let schema = fromConf (schemaConf nerf)         xs = CRF.tag (crf nerf) (schematize schema ws)     in  IOB.decodeForest [IOB.IOB w x | (w, x) <- zip ws xs]
NLP/Nerf/Dict.hs view
@@ -1,47 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Extraction utilities for various dictionary resources.+ module NLP.Nerf.Dict-( preparePNEG-, prepareNELexicon+( extractPoliMorf+, extractPNEG+, extractNELexicon+, extractProlexbase+, extractIntTriggers+, extractExtTriggers , module NLP.Nerf.Dict.Base ) where -import Control.Applicative ((<$>))-import Control.Arrow (first)-import Data.Binary (encodeFile)+import Control.Applicative ((<$>), (<*>)) import qualified Data.PoliMorf as Poli-import qualified Data.Map as M-import qualified Data.Text as T  import NLP.Nerf.Dict.Base import NLP.Nerf.Dict.PNEG (readPNEG) import NLP.Nerf.Dict.NELexicon (readNELexicon)-import qualified NLP.Adict.Trie as Trie+import NLP.Nerf.Dict.Prolexbase (readProlexbase)+import qualified NLP.Nerf.Dict.PNET as PNET --- | Make dictionary consisting only from one word NEs.-mkDictW1 :: [Entry] -> NeDict-mkDictW1 =-    let oneWord x _ = not (isMultiWord x)-    in  siftDict oneWord . mkDict+-- | Is it a single word entry?+atomic :: Entry -> Bool+atomic = not . isMultiWord . neOrth --- | Parse the PNEG dictionary and save it in a binary form into--- the output file.-preparePNEG+-- | Extract NEs dictionary from PNEG.+extractPNEG     :: FilePath     -- ^ Path to PNEG in the LMF format-    -> FilePath     -- ^ Output file-    -> IO ()-preparePNEG lmfPath outPath = do-    neDict <- mkDictW1 <$> readPNEG lmfPath-    saveDict outPath neDict+    -> IO Dict+extractPNEG lmfPath =+    fromEntries . filter atomic <$> readPNEG lmfPath --- | Parse the NELexicon, merge it with the PoliMorf and serialize--- into a binary, DAWG form.-prepareNELexicon+-- | Extract NEs dictionary from NELexicon.+extractNELexicon     :: FilePath     -- ^ Path to NELexicon-    -> FilePath     -- ^ Path to PoliMorf-    -> FilePath     -- ^ Output file-    -> IO ()-prepareNELexicon nePath poliPath outPath = do-    neDict  <- mkDictW1 <$> readNELexicon nePath-    baseMap <- Poli.mkBaseMap <$> Poli.readPoliMorf poliPath-    let neDict' = Poli.merge baseMap neDict-        trie    = Trie.fromList $ map (first T.unpack) (M.assocs neDict')-    encodeFile outPath (Trie.serialize trie)+    -> IO Dict+extractNELexicon nePath =+    fromEntries . filter atomic <$> readNELexicon nePath++-- | Extract NEs dictionary from PoliMorf.+extractPoliMorf+    :: FilePath     -- ^ Path to PoliMorf+    -> IO Dict+extractPoliMorf poliPath+    = fromPairs . filter (cond . snd)+    . map ((,) <$> Poli.form <*> Poli.cat)+    <$> Poli.readPoliMorf poliPath+  where+    cond x = x /= "pospolita" && x /= ""++-- | Extract NEs dictionary from Prolexbase.+extractProlexbase+    :: FilePath     -- ^ Path to Prolexbase+    -> IO Dict+extractProlexbase proPath = do+    fromEntries . filter atomic <$> readProlexbase proPath++-- | Extract internal triggers from PNET dictionary.+extractIntTriggers+    :: FilePath     -- ^ Path to PNET+    -> IO Dict+extractIntTriggers pnetPath =+    mkTriggers PNET.Internal <$> PNET.readPNET pnetPath++-- | Extract external triggers from PNET dictionary.+extractExtTriggers+    :: FilePath     -- ^ Path to PNET+    -> IO Dict+extractExtTriggers pnetPath =+    mkTriggers PNET.External <$> PNET.readPNET pnetPath++mkTriggers :: PNET.Typ -> [PNET.Entry] -> Dict+mkTriggers typ+    = fromPairs+    . filter (not . isMultiWord . fst) +    . map ((,) <$> PNET.orth <*> PNET.neTyp)+    . filter (PNET.hasTyp typ)
NLP/Nerf/Dict/Base.hs view
@@ -1,16 +1,20 @@+{-# LANGUAGE TupleSections #-}+ -- | Basic types for dictionary handling.   module NLP.Nerf.Dict.Base ( -- * Lexicon entry-  Form+  NeType+, Form , isMultiWord-, NeType , Entry (..)  -- * Dictionary-, NeDict-, mkDict+, Label+, Dict+, fromPairs+, fromEntries , siftDict , saveDict , loadDict@@ -20,13 +24,16 @@ , diff ) where -import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<*>)) import Data.Binary (encodeFile, decodeFile) import Data.Text.Binary () import qualified Data.Text as T import qualified Data.Set as S-import qualified Data.Map as M+import qualified Data.DAWG as D +-- | A type of named entity.+type NeType = T.Text+ -- | A orthographic form. type Form = T.Text @@ -34,51 +41,71 @@ isMultiWord :: Form -> Bool isMultiWord = (>1) . length . T.words --- | A type of named entity.-type NeType = T.Text- -- | A Named Entity entry from the LMF dictionary. data Entry = Entry     { neOrth :: !Form	-- ^ Orthographic form of the NE     , neType :: !NeType -- ^ Type of the NE     } deriving (Show, Read, Eq, Ord) --- | A NeDict is a map from forms to NE types.  Each NE may be annotated--- with multiple types.-type NeDict = M.Map Form (S.Set NeType)+-- | Dictionary label.+type Label = T.Text --- | Construct the dictionary from the list of entries.-mkDict :: [Entry] -> NeDict-mkDict xs = M.fromListWith S.union-    [(neOrth x, S.singleton $ neType x) | x <- xs]+-- | A 'Dict' is a map from forms to labels.  Each form may be annotated+-- with multiple labels.  The map is represented using the directed acyclic+-- word graph.+type Dict = D.DAWG (S.Set Label) +-- | Construct dictionary from the list of form/label pairs.+fromPairs :: [(Form, Label)] -> Dict+fromPairs xs = D.fromListWith S.union+    [ ( T.unpack x+      , S.singleton y)+    | (x, y) <- xs ]++-- | Construct dictionary from the list of entries.+fromEntries :: [Entry] -> Dict+fromEntries = fromPairs . map ((,) <$> neOrth <*> neType)+ -- | Remove dictionary entries which do not satisfy the predicate.-siftDict :: (Form -> S.Set NeType -> Bool) -> NeDict -> NeDict-siftDict f dict = M.fromList [(k, v) | (k, v) <- M.assocs dict, f k v]+siftDict :: (Form -> S.Set Label -> Bool) -> Dict -> Dict+siftDict f dict = D.fromList [(k, v) | (k, v) <- D.assocs dict, f (T.pack k) v]  -- | Save the dictionary in the file.-saveDict :: FilePath -> NeDict -> IO ()+saveDict :: FilePath -> Dict -> IO () saveDict = encodeFile  -- | Load the dictionary from the file.-loadDict :: FilePath -> IO NeDict+loadDict :: FilePath -> IO Dict loadDict = decodeFile  -- | Merge dictionary resources.-merge :: [NeDict] -> NeDict-merge = M.unionsWith S.union+merge :: [Dict] -> Dict+merge = unionsWith S.union +-- | Replacement implementation of unionsWith while there is+-- no such function in dawg library. +unionsWith :: Ord a => (a -> a -> a) -> [D.DAWG a] -> D.DAWG a+unionsWith f = foldl (unionWith f) D.empty++-- | Replacement implementation of unionWith while there is+-- no such function in dawg library. +unionWith :: Ord a => (a -> a -> a) -> D.DAWG a -> D.DAWG a -> D.DAWG a+unionWith f d d' = D.fromListWith f (D.assocs d ++ D.assocs d')+ -- | Differentiate labels from separate dictionaries using -- dictionary-unique prefixes.-diff :: [NeDict] -> [NeDict]+diff :: [Dict] -> [Dict] diff ds =-    [ mapS (addPrefix i) <$> dict+    [ mapS (addPrefix i) `mapD` dict     | (i, dict) <- zip [0..] ds ] +-- | Map function over the DAWG elements.+mapD :: Ord b => (a -> b) -> D.DAWG a -> D.DAWG b+mapD f d = D.fromList [(x, f y) | (x, y) <- D.assocs d]+ -- | Map function over the set.-mapS :: Ord a => (a -> a) -> S.Set a -> S.Set a+mapS :: Ord b => (a -> b) -> S.Set a -> S.Set b mapS f s = S.fromList [f x | x <- S.toList s]-{-# INLINE mapS #-}  -- | Add integer prefix. addPrefix :: Int -> T.Text -> T.Text
NLP/Nerf/Dict/NELexicon.hs view
@@ -16,7 +16,7 @@  parseLine :: L.Text -> Entry parseLine line = case L.break (==';') line of-    (_type, _form) -> Entry (L.toStrict $ L.tail _form) (L.toStrict _type)+    (_type, _form) -> Entry (L.toStrict $ L.drop 2 _form) (L.toStrict _type)     _   -> error $ "parseLine: invalid line \"" ++ L.unpack line ++ "\""  -- | Read the dictionary from the file.
+ NLP/Nerf/Dict/Prolexbase.hs view
@@ -0,0 +1,25 @@+-- | Handling Prolexbase dictionaries, both with the+-- same storage format.++module NLP.Nerf.Dict.Prolexbase+( parseProlexbase+, readProlexbase+) where++import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L++import NLP.Nerf.Dict.Base++-- | Parse dictionary into a list of entries.+parseProlexbase :: L.Text -> [Entry]+parseProlexbase = map parseLine . L.lines++parseLine :: L.Text -> Entry+parseLine row = case map L.toStrict (L.split (=='\t') row) of+    [_form, _base, _tag, _cat] -> Entry _form _cat+    _   -> error $ "parseLine: invalid row \"" ++ L.unpack row ++ "\""++-- | Read the dictionary from the file.+readProlexbase :: FilePath -> IO [Entry]+readProlexbase = fmap parseProlexbase . L.readFile
NLP/Nerf/Schema.hs view
@@ -5,49 +5,56 @@  module NLP.Nerf.Schema ( --- * Schema+-- * Types   Ox , Schema , void , sequenceS_ --- * Using the schema+-- * Usage , schematize --- * Building schema---- ** From config-, SchemaCfg (..)-, defaultCfg-, fromCfg+-- ** Configuration+, Body (..)+, Entry+, entry+, entryWith+, SchemaConf (..)+, nullConf+, defaultConf+, fromConf  -- ** Schema blocks , Block , fromBlock-, orthS-, lemmaS-, shapeS-, shapePairS-, suffixS-, searchS+, orthB+, splitOrthB+, lowPrefixesB+, lowSuffixesB+, lemmaB+, shapeB+, packedB+, shapePairB+, packedPairB+, dictB ) where  import Control.Applicative ((<$>), (<*>)) import Control.Monad (forM_, join) import Data.Maybe (maybeToList)-import Data.Binary (Binary, put, get, decodeFile)+import Data.Binary (Binary, put, get) import qualified Data.Char as C import qualified Data.Set as S-import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.Text as T+import qualified Data.DAWG as D  import qualified Data.CRF.Chain1 as CRF import qualified Control.Monad.Ox as Ox import qualified Control.Monad.Ox.Text as Ox  import NLP.Nerf.Types-import qualified NLP.Nerf.Dict as Dict+import NLP.Nerf.Dict (Dict)  -- | The Ox monad specialized to word token type and text observations. type Ox a = Ox.Ox Word T.Text a@@ -60,8 +67,8 @@ void :: a -> Schema a void x _ _ = return x --- | Sequence the list of schemas and discard individual values.-sequenceS_ :: [Schema a] -> Schema ()+-- | Sequence the list of schemas (or blocks) and discard individual values.+sequenceS_ :: [V.Vector Word -> a -> Ox b] -> V.Vector Word -> a -> Ox () sequenceS_ xs sent =     let ys = map ($sent) xs     in  \k -> sequence_ (map ($k) ys)@@ -85,17 +92,23 @@ -- context of the sentence and the list of absolute sentence positions. type Block a = V.Vector Word -> [Int] -> Ox a --- | Transform the block to the schema dependent on the list of+-- | Transform the block to the schema depending on the list of -- relative sentence positions. fromBlock :: Block a -> [Int] -> Schema a fromBlock blk xs sent =     let blkSent = blk sent     in  \k -> blkSent [x + k | x <- xs] --- | Orthographic observations determined with respect to the--- list of relative positions.-orthS :: Block ()-orthS sent = \ks -> do+-- | Orthographic form at the current position.+orthB :: Block ()+orthB sent = \ks ->+    let orthOb = Ox.atWith sent id+    in  mapM_ (Ox.save . orthOb) ks++-- | Orthographic form split into two observations: the lowercased form and+-- the original form (only when different than the lowercased one).+splitOrthB :: Block ()+splitOrthB sent = \ks -> do     mapM_ (Ox.save . lowOrth)    ks     mapM_ (Ox.save . upOnlyOrth) ks   where@@ -104,124 +117,239 @@         True    -> Just x         False   -> Nothing --- | Lemma substitute determined with respect to the list of--- relative positions.-lemmaS :: Block ()-lemmaS sent = \ks -> do+-- | List of lowercased prefixes of given lengths.+lowPrefixesB :: [Int] -> Block ()+lowPrefixesB ns sent = \ks ->+    forM_ ks $ \i ->+        mapM_ (Ox.save . lowPrefix i) ns+  where+    BaseOb{..}      = mkBaseOb sent+    lowPrefix i j   = Ox.prefix j =<< lowOrth i++-- | List of lowercased suffixes of given lengths.+lowSuffixesB :: [Int] -> Block ()+lowSuffixesB ns sent = \ks ->+    forM_ ks $ \i ->+        mapM_ (Ox.save . lowSuffix i) ns+  where+    BaseOb{..}      = mkBaseOb sent+    lowSuffix i j   = Ox.suffix j =<< lowOrth i++-- | Lemma substitute parametrized by the number specifying the span+-- over which lowercased prefixes and suffixes will be 'Ox.save'd.+-- For example, @lemmaB 2@ will take affixes of lengths @0, -1@ and @-2@+-- on account.+lemmaB :: Int -> Block ()+lemmaB n sent = \ks -> do     mapM_ lowLemma ks   where     BaseOb{..}      = mkBaseOb sent     lowPrefix i j   = Ox.prefix j =<< lowOrth i     lowSuffix i j   = Ox.suffix j =<< lowOrth i     lowLemma i = Ox.group $ do-        mapM_ (Ox.save . lowPrefix i) [0, -1, -2, -3]-        mapM_ (Ox.save . lowSuffix i) [0, -1, -2, -3]+        mapM_ (Ox.save . lowPrefix i) [0, -1 .. -n]+        mapM_ (Ox.save . lowSuffix i) [0, -1 .. -n] --- | Shape and packed shape determined with respect to the list of--- relative positions.-shapeS :: Block ()-shapeS sent = \ks -> do-    mapM_ (Ox.save . shape)  ks+-- | Shape of the word.+shapeB :: Block ()+shapeB sent = \ks -> do+    mapM_ (Ox.save . shape) ks+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i++-- | Packed shape of the word.+packedB :: Block ()+packedB sent = \ks -> do     mapM_ (Ox.save . shapeP) ks   where     BaseOb{..}      = mkBaseOb sent     shape i         = Ox.shape <$> orth i     shapeP i        = Ox.pack <$> shape i --- | Shape pairs determined with respect to the list of relative positions.-shapePairS :: Block ()-shapePairS sent = \ks ->+-- -- | Shape and packed shape of the word.+-- shapeAndPackedB :: Block ()+-- shapeAndPackedB sent = \ks -> do+--     mapM_ (Ox.save . shape)  ks+--     mapM_ (Ox.save . shapeP) ks+--   where+--     BaseOb{..}      = mkBaseOb sent+--     shape i         = Ox.shape <$> orth i+--     shapeP i        = Ox.pack <$> shape i++-- | Combined shapes of two consecutive (at @k-1@ and @k@ positions) words.+shapePairB :: Block ()+shapePairB sent = \ks ->     forM_ ks $ \i -> do         Ox.save $ link <$> shape  i <*> shape  (i - 1)-        Ox.save $ link <$> shapeP i <*> shapeP (i - 1)   where     BaseOb{..}      = mkBaseOb sent     shape i         = Ox.shape <$> orth i-    shapeP i        = Ox.pack <$> shape i     link x y        = T.concat [x, "-", y] --- | Several suffixes determined with respect to the list of--- relative positions.-suffixS :: Block ()-suffixS sent = \ks ->-    forM_ ks $ \i ->-        mapM_ (Ox.save . lowSuffix i) [2, 3, 4]+-- | Combined packed shapes of two consecutive (at @k-1@ and @k@ positions)+-- words.+packedPairB :: Block ()+packedPairB sent = \ks ->+    forM_ ks $ \i -> do+        Ox.save $ link <$> shapeP i <*> shapeP (i - 1)   where     BaseOb{..}      = mkBaseOb sent-    lowSuffix i j   = Ox.suffix j =<< lowOrth i+    shape i         = Ox.shape <$> orth i+    shapeP i        = Ox.pack <$> shape i+    link x y        = T.concat [x, "-", y]  -- | Plain dictionary search determined with respect to the list of -- relative positions.-searchS :: Dict.NeDict -> Block ()-searchS dict sent = \ks -> do+dictB :: Dict -> Block ()+dictB dict sent = \ks -> do     mapM_ (Ox.saves . searchDict) ks   where     BaseOb{..}      = mkBaseOb sent     searchDict i    = join . maybeToList $-        S.toList <$> (orth i >>= flip M.lookup dict)+        S.toList <$> (orth i >>= flip D.lookup dict . T.unpack) +-- | Body of configuration entry.+data Body a = Body {+    -- | Range argument for the schema block. +      range :: [Int]+    -- | Additional arguments for the schema block.+    , args  :: a }+    deriving (Show)++instance Binary a => Binary (Body a) where+    put Body{..} = put range >> put args+    get = Body <$> get <*> get++-- | Maybe entry.+type Entry a = Maybe (Body a)++-- | Entry with additional arguemnts.+entryWith :: a -> [Int] -> Entry a+entryWith v xs = Just (Body xs v)++-- | Maybe entry with additional arguemnts.+entryWith'Mb :: Maybe a -> [Int] -> Entry a+entryWith'Mb (Just v) xs = Just (Body xs v)+entryWith'Mb Nothing _   = Nothing++-- | Plain entry with no additional arugments.+entry :: [Int] -> Entry ()+entry = entryWith ()+ -- | Configuration of the schema.  All configuration elements specify the -- range over which a particular observation type should be taken on account. -- For example, the @[-1, 0, 2]@ range means that observations of particular -- type will be extracted with respect to previous (@k - 1@), current (@k@) -- and after the next (@k + 2@) positions when identifying the observation -- set for position @k@ in the input sentence.-data SchemaCfg = SchemaCfg-    { orthC         :: [Int]    -- ^ The 'orthS' schema block-    , lemmaC        :: [Int]    -- ^ The 'lemmaS' schema block-    , shapeC        :: [Int]    -- ^ The 'shapeS' schema block-    , shapePairC    :: [Int]    -- ^ The 'shapePairS' schema block-    , suffixC       :: [Int]    -- ^ The 'suffixS' schema block-    , dictC     :: Maybe (Dict.NeDict, [Int]) -- ^ The 'searchS' schema block-    }+data SchemaConf = SchemaConf {+    -- | The 'orthB' schema block.+      orthC             :: Entry ()+    -- | The 'splitOrthB' schema block.+    , splitOrthC        :: Entry ()+    -- | The 'lowPrefixesB' schema block.  The first list of ints+    -- represents lengths of prefixes.+    , lowPrefixesC      :: Entry [Int]+    -- | The 'lowSuffixesB' schema block.  The first list of ints+    -- represents lengths of suffixes.+    , lowSuffixesC      :: Entry [Int]+    -- | The 'lemmaB' schema block.+    , lemmaC            :: Entry Int+    -- | The 'shapeB' schema block.+    , shapeC            :: Entry ()+    -- | The 'packedB' schema block.+    , packedC           :: Entry ()+    -- | The 'shapePairB' schema block.+    , shapePairC        :: Entry ()+    -- | The 'packedPairB' schema block.+    , packedPairC       :: Entry ()+    -- | Dictionaries of NEs ('dictB' schema block).+    , dictC             :: Entry [Dict]+    -- | Dictionary of internal triggers.+    , intTrigsC         :: Entry Dict+    -- | Dictionary of external triggers.+    , extTrigsC         :: Entry Dict+    } deriving (Show) -instance Binary SchemaCfg where-    put SchemaCfg{..} = do+instance Binary SchemaConf where+    put SchemaConf{..} = do         put orthC+        put splitOrthC+        put lowPrefixesC+        put lowSuffixesC         put lemmaC         put shapeC+        put packedC         put shapePairC-        put suffixC+        put packedPairC         put dictC-    get = SchemaCfg-        <$> get-        <*> get-        <*> get-        <*> get-        <*> get-        <*> get+        put intTrigsC+        put extTrigsC+    get = SchemaConf+        <$> get <*> get <*> get <*> get+        <*> get <*> get <*> get <*> get+        <*> get <*> get <*> get <*> get --- | Default configuration for Nerf observation schema.-defaultCfg-    :: FilePath     -- ^ Path to 'Dict.NeDict' in a binary form-    -> IO SchemaCfg-defaultCfg nePath = do-    neDict <- decodeFile nePath-    return $ SchemaCfg-        { orthC         = [-1, 0]-        , lemmaC        = [-1, 0]-        , shapeC        = [-1, 0]-        , shapePairC    = [0]-        , suffixC       = [0]-        , dictC         = Just (neDict, [-1, 0]) }+-- | Null configuration of the observation schema.+nullConf :: SchemaConf+nullConf = SchemaConf+    Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing -mkBasicS :: Block () -> [Int] -> Schema ()-mkBasicS _   [] = void ()-mkBasicS blk xs = fromBlock blk xs+-- | Default configuration of the observation schema.+defaultConf+    :: [Dict]       -- ^ Named Entity dictionaries+    -> Maybe Dict   -- ^ Dictionary of internal triggers+    -> Maybe Dict   -- ^ Dictionary of external triggers+    -> IO SchemaConf+defaultConf neDicts intDict extDict = do+    return $ SchemaConf+        { orthC         = Nothing+        , splitOrthC    = entry                 [-1, 0]+        , lowPrefixesC  = Nothing+        , lowSuffixesC  = entryWith [2, 3, 4]   [0]+        , lemmaC        = entryWith 3           [-1, 0]+        , shapeC        = entry                 [-1, 0]+        , packedC       = entry                 [-1, 0]+        , shapePairC    = entry                 [0]+        , packedPairC   = entry                 [0]+        , dictC         = entryWith neDicts     [-1, 0]+        , intTrigsC     = entryWith'Mb intDict  [0]+        , extTrigsC     = entryWith'Mb extDict  [-1] } -mkDictS :: Maybe (Dict.NeDict, [Int]) -> Schema ()-mkDictS (Just (d, xs))  = fromBlock (searchS d) xs-mkDictS Nothing         = void ()+mkArg0 :: Block () -> Entry () -> Schema ()+mkArg0 blk (Just x) = fromBlock blk (range x)+mkArg0 _   Nothing  = void () +mkArg1 :: (a -> Block ()) -> Entry a -> Schema ()+mkArg1 blk (Just x) = fromBlock (blk (args x)) (range x)+mkArg1 _   Nothing  = void ()++mkArgs1 :: (a -> Block ()) -> Entry [a] -> Schema ()+mkArgs1 blk (Just x) = sequenceS_+    [ fromBlock+        (blk dict)+        (range x)+    | dict <- args x ]+mkArgs1 _   Nothing  = void ()+ -- | Build the schema based on the configuration.-fromCfg :: SchemaCfg -> Schema ()-fromCfg SchemaCfg{..} = sequenceS_-    [ mkBasicS orthS orthC-    , mkBasicS lemmaS lemmaC-    , mkBasicS shapeS shapeC-    , mkBasicS shapePairS shapePairC-    , mkBasicS suffixS suffixC-    , mkDictS dictC ]+fromConf :: SchemaConf -> Schema ()+fromConf SchemaConf{..} = sequenceS_+    [ mkArg0 orthB orthC+    , mkArg0 splitOrthB splitOrthC+    , mkArg1 lowPrefixesB lowPrefixesC+    , mkArg1 lowSuffixesB lowSuffixesC+    , mkArg1 lemmaB lemmaC+    , mkArg0 shapeB shapeC+    , mkArg0 packedB packedC+    , mkArg0 shapePairB shapePairC+    , mkArg0 packedPairB packedPairC+    , mkArgs1 dictB dictC+    , mkArg1 dictB intTrigsC+    , mkArg1 dictB extTrigsC ]  -- | Use the schema to extract observations from the sentence. schematize :: Schema a -> [Word] -> CRF.Sent Ob
nerf.cabal view
@@ -1,5 +1,5 @@ name:               nerf-version:            0.1.0+version:            0.2.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@@ -32,14 +32,14 @@       , vector       , text       , binary-      , text-binary+      , text-binary >= 0.1 && < 0.2       , polysoup >= 0.1 && < 0.2       , crf-chain1 >= 0.2 && < 0.3       , data-named >= 0.5 && < 0.6       , monad-ox >= 0.2 && < 0.3       , sgd >= 0.2.1 && < 0.3-      , polimorf >= 0.3.1 && < 0.4-      , adict >= 0.2 && < 0.3+      , polimorf >= 0.5.0 && < 0.6+      , dawg >= 0.5 && < 0.6       , cmdargs      exposed-modules:@@ -50,6 +50,7 @@       , NLP.Nerf.Dict.Base       , NLP.Nerf.Dict.PNEG       , NLP.Nerf.Dict.NELexicon+      , NLP.Nerf.Dict.Prolexbase      ghc-options: -Wall -O2 @@ -57,6 +58,7 @@     type: git     location: git://github.com/kawu/nerf.git -Executable nerf-  Hs-Source-Dirs: ., tools-  Main-is: nerf.hs+executable nerf+  hs-source-dirs: ., tools+  main-is: nerf.hs+  ghc-options: -Wall -O2 -threaded
tools/nerf.hs view
@@ -3,8 +3,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -import Control.Monad (forM_, when) 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)@@ -12,42 +17,50 @@ 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 as D  import NLP.Nerf (train, ner, tryOx)-import NLP.Nerf.Schema (defaultCfg)-import NLP.Nerf.Dict (preparePNEG, prepareNELexicon)+import NLP.Nerf.Schema (defaultConf)+import NLP.Nerf.Dict+    ( extractPoliMorf, extractPNEG, extractNELexicon, extractProlexbase+    , extractIntTriggers, extractExtTriggers, Dict ) -data Args-  = TrainMode-    { trainPath	    :: FilePath-    , neDictPath    :: FilePath-    , evalPath      :: Maybe FilePath+data Nerf+  = Train+    { trainPath     :: FilePath+    , eval          :: Maybe 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     , outNerf       :: FilePath }-  | NerMode+  | NER     { dataPath      :: FilePath     , inNerf        :: FilePath }-  | OxMode+  | Ox     { dataPath      :: FilePath-    , neDictPath    :: FilePath }-  | PnegMode-    { lmfPath       :: FilePath-    , outPath       :: FilePath }-  | NeLexMode-    { nePath        :: FilePath-    , poliPath      :: FilePath-    , outPath       :: FilePath }+    , poliMorf      :: Maybe FilePath+    , prolex        :: Maybe FilePath+    , pneg          :: Maybe FilePath+    , neLex         :: Maybe FilePath+    , pnet          :: Maybe FilePath }   deriving (Data, Typeable, Show) -trainMode :: Args-trainMode = TrainMode+trainMode :: Nerf+trainMode = Train     { trainPath = def &= argPos 0 &= typ "TRAIN-FILE"-    , neDictPath = def &= argPos 1 &= typ "NE-DICT-FILE"-    , evalPath = def &= typFile &= help "Evaluation file"+    , eval = 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"+    , 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"@@ -55,42 +68,69 @@     , tau = 5.0 &= help "Initial tau parameter"     , outNerf = def &= typFile &= help "Output Nerf file" } -nerMode :: Args-nerMode = NerMode+nerMode :: Nerf+nerMode = NER     { inNerf = def &= argPos 0 &= typ "NERF-FILE"-    , dataPath = def &= argPos 2 &= typ "INPUT" }---     , dataPath = def &= typFile &= help "Input" }---         &= help "Input file; if not specified, read from stdin" }+    , dataPath = def &= argPos 1 &= typ "INPUT" } -oxMode :: Args-oxMode = OxMode+oxMode :: Nerf+oxMode = Ox     { dataPath = def &= argPos 0 &= typ "DATA-FILE"-    , neDictPath = def &= argPos 1 &= typ "NE-DICT-FILE" }+    , 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" } -pnegMode :: Args-pnegMode = PnegMode-    { lmfPath = def &= typ "PNEG" &= argPos 0-    , outPath = def &= typ "Output" &= argPos 1 }+argModes :: Mode (CmdArgs Nerf)+argModes = cmdArgsMode $ modes [trainMode, nerMode, oxMode] -neLexMode :: Args-neLexMode = NeLexMode-    { nePath = def &= typ "NELexicon" &= argPos 0-    , poliPath = def &= typ "PoliMorf" &= argPos 1-    , outPath = def &= typ "Output" &= argPos 2 }+data Resources = Resources+    { poliDict      :: Maybe Dict+    , prolexDict    :: Maybe Dict+    , pnegDict      :: Maybe Dict+    , neLexDict     :: Maybe Dict+    , intDict       :: Maybe Dict+    , extDict       :: Maybe Dict } -argModes :: Mode (CmdArgs Args)-argModes = cmdArgsMode $ modes [trainMode, nerMode, oxMode, pnegMode, neLexMode]+extract :: Nerf -> IO Resources+extract nerf = withBuffering stdout NoBuffering $ Resources+    <$> extractDict "PoliMorf" extractPoliMorf (poliMorf nerf)+    <*> extractDict "Prolexbase" extractProlexbase (prolex nerf)+    <*> extractDict "PNEG" extractPNEG (pneg nerf)+    <*> extractDict "NELexicon" extractNELexicon (neLex nerf)+    <*> 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+    hSetBuffering h mode+    x <- io+    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+    return (Just dict)+extractDict _ _ Nothing = return Nothing+ main :: IO ()-main = do-    args <- cmdArgsRun argModes-    exec args+main = exec =<< cmdArgsRun argModes -exec :: Args -> IO ()+exec :: Nerf -> IO () -exec TrainMode{..} = do-    cfg  <- defaultCfg neDictPath-    nerf <- train sgdArgs cfg trainPath evalPath+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@@ -102,19 +142,19 @@         , SGD.gain0 = gain0         , SGD.tau = tau } -exec NerMode{..} = do+exec NER{..} = do     nerf  <- decodeFile inNerf     input <- readRaw dataPath     forM_ input $ \sent -> do         let forest = ner nerf sent         L.putStrLn (showForest forest) -exec OxMode{..} = do-    cfg  <- defaultCfg neDictPath+exec nerfArgs@Ox{..} = do+    Resources{..} <- extract nerfArgs+    cfg <- defaultConf+        (catMaybes [poliDict, prolexDict, pnegDict, neLexDict])+        intDict extDict     tryOx cfg dataPath--exec PnegMode{..} = preparePNEG lmfPath outPath-exec NeLexMode{..} = prepareNELexicon nePath poliPath outPath  parseRaw :: L.Text -> [[T.Text]] parseRaw =