nerf 0.5.0 → 0.5.1

raw patch · 4 files changed

+121/−87 lines, 4 filesdep +IntervalMapdep ~cmdargsdep ~directoryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: IntervalMap

Dependency ranges changed: cmdargs, directory

API changes (from Hackage documentation)

Files

• nerf.cabal +4/−3
• src/NLP/Nerf.hs +2/−2
• src/NLP/Nerf/Tokenize.hs +114/−81
• src/NLP/Nerf/XCES.hs +1/−1

@@ -1,5 +1,5 @@ name:               nerf-version:            0.5.0+version:            0.5.1 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@@ -47,7 +47,8 @@       , tokenize            == 0.1.3       , mtl                 >= 2.1      && < 2.2       , network             >= 2.3      && < 2.4-      , cmdargs+      , cmdargs             >= 0.10     && < 0.11+      , IntervalMap         >= 0.3      && < 0.4      exposed-modules:         NLP.Nerf@@ -74,7 +75,7 @@   hs-source-dirs: src, tools   build-depends:     filepath            >= 1.3      && < 1.4,-    directory           >= 1.2      && < 1.3,+    directory           >= 1.1      && < 1.3,     temporary           >= 1.1      && < 1.2   main-is: nerf.hs   ghc-options: -Wall -O2 -threaded -rtsopts

@@ -26,7 +26,7 @@ import qualified Data.CRF.Chain1 as CRF  import NLP.Nerf.Types-import NLP.Nerf.Tokenize (tokenize, moveNEs)+import NLP.Nerf.Tokenize (tokenize, sync) import NLP.Nerf.Schema (SchemaConf, Schema, fromConf, schematize)  -- | A Nerf consists of the observation schema configuration and the CRF model.@@ -50,7 +50,7 @@ -- | Tokenize sentence with the Nerf tokenizer. reTokenize :: N.NeForest NE Word -> N.NeForest NE Word reTokenize ft = -    moveNEs ft ((doTok . leaves) ft)+    sync ft ((doTok . leaves) ft)   where      doTok  = map T.pack . tokenize . intercalate " "  . map T.unpack     leaves = concatMap $ foldMap (either (const []) (:[]))

@@ -1,20 +1,23 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} + -- | The module implements the tokenization used within Nerf -- and some other tokenization-related stuff. + module NLP.Nerf.Tokenize ( -- * Tokenization   tokenize -- * Synchronization , Word (..)-, moveNEs+, sync ) where -import Control.Monad ((>=>))-import Data.Foldable (foldMap)++import           Control.Arrow (second)+import           Control.Monad ((>=>)) import qualified Data.Char as Char import qualified Data.List as L import qualified Data.Tree as T@@ -22,13 +25,16 @@ import qualified Data.Text as Text import qualified Data.Text.Lazy as LazyText import qualified NLP.Tokenize as Tok+import qualified Data.IntervalMap.Strict as I -import Data.Named.Tree (NeForest, NeTree, groupForestLeaves)+import           Data.Named.Tree (NeForest, NeTree) ------------------------------- Tokenization definition.---------------------------- +-------------------------------------+-- Tokenization definition+-------------------------------------++ -- | Default tokenizator. defaultTokenizer :: Tok.Tokenizer defaultTokenizer@@ -36,115 +42,142 @@     >=> Tok.uris     >=> Tok.punctuation + -- | Tokenize sentence using the default tokenizer. tokenize :: String -> [String] tokenize = Tok.run defaultTokenizer ------------------------------------------------------------------- Synchronizing named entities with new sentence tokenization.---------------------------------------------------------------- +-------------------------------------+-- Word+-------------------------------------++ -- | A class of objects which can be converted to `String`. class Word a where     word :: a -> String + instance Word String where     word = id + instance Word Text.Text where     word = Text.unpack + instance Word LazyText.Text where     word = LazyText.unpack + essence :: Word a => a -> Int essence = length . filter (not . Char.isSpace) . word {-# INLINE essence #-} --- | Syncronization between two sentences.  Each (xs, ys) pair represents--- tokens from the two input sentences which corresponds to each other.-type Sync a b = [([a], [b])] --- | Synchronize two tokenizations of the sentence.-sync :: (Word a, Word b) => [a] -> [b] -> Sync a b-sync = sync' 0+-------------------------------------+-- Grouping leaves+------------------------------------- -sync' :: (Word a, Word b) => Int -> [a] -> [b] -> Sync a b-sync' r (x:xs) (y:ys)-    | n + r == m    = ([x], [y])    : sync' 0       xs    ys-    | n + r  < m    = join x        $ sync' (n + r) xs (y:ys)-    | otherwise     = swap . join y $ sync' (m - r) ys (x:xs)-  where-    n = essence x-    m = essence y-    join l ((ls, rs) : ps)  = (l:ls, rs) : ps-    join _ []               = error "sync'.join: bad arguments"-    swap ((ls, rs) : ps)    = (rs, ls) : swap ps-    swap []                 = []-sync' 0 [] [] = []-sync' _ _  _  = error "sync': bad arguments" --- | Match the `Sync` with the given list, return the matching result--- (snd elements of the `Sync` list) and the rest of the `Sync` list.-match :: (Word a, Word b) => [a] -> Sync a b -> ([b], Sync a b)-match xs ss =-    let (sl, sr) = splitAcc isMatch 0 ss-    in  (concatMap snd sl, sr)-  where-    n = sum (map essence xs)-    isMatch r (ys, _)-        | m + r < n     = (m + r, False)-        | m + r == n    = (m + r, True)-        | otherwise     = error "match.isMatch: no match"-      where-        m = sum (map essence ys)---- | Split the list with the help of the accumulating function.-splitAcc :: (acc -> a -> (acc, Bool)) -> acc -> [a] -> ([a], [a])-splitAcc _ _ [] = ([], [])-splitAcc f acc (x:xs)-    | cond      = ([x], xs)-    | otherwise = join x (splitAcc f acc' xs)-  where-    (acc', cond) = f acc x-    join y (ys, zs) = (y:ys, zs)---- | List forest leaves.-leaves :: NeForest a b -> [b]-leaves = concatMap $ foldMap (either (const []) (:[]))- unGroupLeaves :: NeForest a [b] -> NeForest a b unGroupLeaves = concatMap unGroupLeavesT + unGroupLeavesT :: NeTree a [b] -> [NeTree a b] unGroupLeavesT (T.Node (Left v) xs)     =     [T.Node (Left v) (unGroupLeaves xs)] unGroupLeavesT (T.Node (Right vs) _)   =     [T.Node (Right v) [] | v <- vs] -substGroups :: (Word b, Word c) => NeForest a [b] -> Sync b c -> NeForest a [c]-substGroups fs ss = snd $ L.mapAccumL substGroupsT ss fs -substGroupsT-    :: (Word b, Word c)-    => Sync b c -> NeTree a [b]-    -> (Sync b c, NeTree a [c])-substGroupsT =-    Tr.mapAccumL f+---------------------------------------------------------------+-- Identifying ranges+---------------------------------------------------------------+++type Range = I.Interval Int+++-- | Range computation step.+ranged :: Word a => Int -> a -> (Int, (Range, a))+ranged p w =+    (q, (i, w))   where-    f s (Left v)  = (s, Left v)-    f s (Right v) =-        let (v', s') = match v s-        in  (s', Right v')+    q = p + essence w+    i = I.IntervalCO p q --- | Synchronize named entities with tokenization represented--- by the second function argument.  Of course, both arguments--- should relate to the same sentence.-moveNEs :: (Word b, Word c) => NeForest a b -> [c] -> NeForest a c-moveNEs ft ys-    = unGroupLeaves-    $ substGroups-        (groupForestLeaves true ft)-        (sync (leaves ft) ys)++-- | Compute ranges of individual tokens.+rangedList :: Word a => [a] -> [(Range, a)]+rangedList = snd . L.mapAccumL ranged 0+++-- | Compute ranges of individual tokens.+rangedForest :: Word b => NeForest a b -> NeForest a (Range, b)+rangedForest = +    snd . L.mapAccumL (Tr.mapAccumL f) 0   where-    true _ _ = True+    f acc (Left x)  = (acc, Left x)+    f acc (Right x) =+        let (acc', y) = ranged acc x+        in  (acc', Right y)+        ++---------------------------------------------------------------+-- Synchronizing named entities with new sentence tokenization+---------------------------------------------------------------+++-- | Replace leaves in the NE forest with corresponding tokens.+replaceToks+    :: I.IntervalMap Int c+    -> NeForest a (Range, b)+    -> ( I.IntervalMap Int c+       , NeForest a (Range, c) )+replaceToks ivMap nes+    = second unGroupLeaves+    $ L.mapAccumL (Tr.mapAccumL replace) ivMap nes+  where+    replace im (Left x) = (im, Left x)+    replace im (Right (ran, _)) =+        let rsXs = I.intersecting im ran+            im'  = L.foldl' (flip I.delete) im (map fst rsXs)+        in  (im', Right rsXs)+++-- | Lift the first range of a tree to the top.+liftRange :: NeTree a (Range, b) -> (Range, NeTree a b)+liftRange (T.Node (Left v) xs) =+    (ran, T.Node (Left v) (map snd ys))+  where+    ys = map liftRange xs+    ran = maybeHead $ map fst ys+    maybeHead (x:_) = x+    maybeHead []    = error "liftRange: invalid NE tree"+liftRange (T.Node (Right (ran, v)) _) = (ran, T.Node (Right v) [])+++-- | Synchronize the list of NE trees with the new tokenization.+sync+    :: (Word b, Word c)+    => NeForest a b     -- ^ NE forest+    -> [c]              -- ^ New tokenization+    -> NeForest a c     -- ^ Resulting NE forest+sync nes0 xs0+    = map snd . I.toList . I.fromList+    $ map (second mkLeaf) (I.toList ivMap')+    ++ map liftRange nes'+  where+    -- Interval map of the new tokenization+    ivMap = I.fromList $ rangedList xs0+    -- NE non-leaf trees with ranges+    nes = filter internal $ rangedForest nes0+    -- Replace tokens...+    (ivMap', nes') = replaceToks ivMap nes+    -- Is it an internal node?+    internal x = case T.rootLabel x of+        Left _  -> True+        Right _ -> False+    -- Make a leaf tree+    mkLeaf x = T.Node (Right x) []

@@ -340,7 +340,7 @@ -- nerSent :: Nerf.Nerf -> Sent [] -> Sent Ann nerSent :: (String -> NeForest NE Word) -> Sent [] -> Sent Ann nerSent nerFun s@Sent{..} = s-    { sentCon = Ann $ Tok.moveNEs+    { sentCon = Ann $ Tok.sync         (nerFun $ restoreOrigSent sentCon)         sentCon }