diff --git a/NLP/Nerf.hs b/NLP/Nerf.hs --- a/NLP/Nerf.hs +++ b/NLP/Nerf.hs @@ -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] diff --git a/NLP/Nerf/Dict.hs b/NLP/Nerf/Dict.hs --- a/NLP/Nerf/Dict.hs +++ b/NLP/Nerf/Dict.hs @@ -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) diff --git a/NLP/Nerf/Dict/Base.hs b/NLP/Nerf/Dict/Base.hs --- a/NLP/Nerf/Dict/Base.hs +++ b/NLP/Nerf/Dict/Base.hs @@ -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 diff --git a/NLP/Nerf/Dict/NELexicon.hs b/NLP/Nerf/Dict/NELexicon.hs --- a/NLP/Nerf/Dict/NELexicon.hs +++ b/NLP/Nerf/Dict/NELexicon.hs @@ -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. diff --git a/NLP/Nerf/Dict/Prolexbase.hs b/NLP/Nerf/Dict/Prolexbase.hs new file mode 100644 --- /dev/null +++ b/NLP/Nerf/Dict/Prolexbase.hs @@ -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 diff --git a/NLP/Nerf/Schema.hs b/NLP/Nerf/Schema.hs --- a/NLP/Nerf/Schema.hs +++ b/NLP/Nerf/Schema.hs @@ -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 diff --git a/nerf.cabal b/nerf.cabal --- a/nerf.cabal +++ b/nerf.cabal @@ -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 diff --git a/tools/nerf.hs b/tools/nerf.hs --- a/tools/nerf.hs +++ b/tools/nerf.hs @@ -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 =