concraft 0.1.0 → 0.2.0

raw patch · 4 files changed

+309/−2 lines, 4 filesdep +crf-chain2-genericdep +tagset-positionalnew-component:exe:concraft-disambPVP ok

version bump matches the API change (PVP)

Dependencies added: crf-chain2-generic, tagset-positional

API changes (from Hackage documentation)

Files

• NLP/Concraft/Disamb.hs +198/−0
• NLP/Concraft/Morphosyntax.hs +13/−0
• concraft.cabal +12/−2
• tools/concraft-disamb.hs +86/−0

@@ -0,0 +1,198 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module NLP.Concraft.Disamb+( Tier (..)+, Tag (..)+, select+, splitWord+, splitSent+, Ox+, Schema+, Ob+, schema+, schematize+, TierConf+, tear+, deTear+, deTears+, Disamb+, disamb+, tagFile+, learn+) where++import Control.Applicative ((<$>), (<*>))+import Data.Maybe (fromJust)+import Data.List (find)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Vector as V++import Data.Binary (Binary, get, put)+import Data.Text.Binary ()++import qualified Control.Monad.Ox as Ox+import qualified Data.CRF.Chain2.Pair as CRF+import qualified Numeric.SGD as SGD+import qualified Data.Tagset.Positional as TP++import NLP.Concraft.Morphosyntax+import qualified NLP.Concraft.Plain as P++-- | A tier description.+data Tier = Tier {+    -- | Does it include the part of speech?+      withPos   :: Bool+    -- | Tier grammatical attributes.+    , withAtts  :: S.Set TP.Attr }++instance Binary Tier where+    put Tier{..} = put withPos >> put withAtts+    get = Tier <$> get <*> get++-- | A tag with optional POS.+data Tag = Tag+    { pos   :: Maybe TP.POS+    , atts  :: M.Map TP.Attr T.Text }+    deriving (Show, Eq, Ord)++instance Binary Tag where+    put Tag{..} = put pos >> put atts+    get = Tag <$> get <*> get++-- | Select tier attributes.+select :: Tier -> TP.Tag -> Tag+select Tier{..} tag = Tag+    { pos   = if withPos then Just (TP.pos tag) else Nothing+    , atts  = M.filterWithKey (\k _ -> k `S.member` withAtts) (TP.atts tag) }++-- | The Ox monad specialized to word token type and text observations.+-- TODO: Move to monad-ox package from here and from the nerf library.+type Ox t a = Ox.Ox (Word t) T.Text a++-- | A schema is a block of the Ox computation performed within the+-- context of the sentence and the absolute sentence position.+type Schema t a = V.Vector (Word t) -> Int -> Ox t a++-- | An observation consist of an index (of list type) and an actual+-- observation value.+type Ob = ([Int], T.Text)++schema :: Schema t ()+schema sent = \k -> do+    mapM_ (Ox.save . lowOrth) [k - 1, k, k + 1]+  where+    at          = Ox.atWith sent+    lowOrth i   = T.toLower <$> orth `at` i++-- | Schematize the input sentence according to 'schema' rules.+schematize :: Sent t -> CRF.Sent Ob t+schematize sent =+    [ CRF.mkWord (obs i) (lbs i)+    | i <- [0 .. n - 1] ]+  where+    v = V.fromList sent+    n = V.length v+    obs = S.fromList . Ox.execOx . schema v+    lbs = tags . (v V.!)++type TierConf = (Tier, Tier)++tear :: TierConf -> TP.Tag -> (Tag, Tag)+tear (t1, t2) = (,) <$> select t1 <*> select t2++-- | Split tags between two layers.+-- TODO: Add support for multiple layers.+splitWord :: TierConf -> Word TP.Tag -> Word (Tag, Tag)+splitWord cfg = mapWord (tear cfg)++splitSent :: TierConf -> Sent TP.Tag -> Sent (Tag, Tag)+splitSent ts = map (splitWord ts)++-- | The disambiguation model.+data Disamb = Disamb+    { crf       :: CRF.CRF Ob Tag Tag+    , tagset    :: TP.Tagset+    , tierConf  :: TierConf }++instance Binary Disamb where+    put Disamb{..} = put crf >> put tagset >> put tierConf+    get = Disamb <$> get <*> get <*> get++-- | Determine the most probable label sequence.+disamb :: Disamb -> Sent TP.Tag -> [TP.Tag]+disamb Disamb{..} sent+    = deTears tierConf sent+    . CRF.tag crf+    . schematize+    . splitSent tierConf+    $ sent++deTears :: TierConf -> Sent TP.Tag -> [(Tag, Tag)] -> [TP.Tag]+deTears cfg sent tiered =+    [ deTear cfg word pair+    | (word, pair) <- zip sent tiered ]++-- | Unsplit the list of tag pairs.  TODO: It can be done without the+-- help of original word.+deTear :: TierConf -> Word TP.Tag -> (Tag, Tag) -> TP.Tag+deTear cfg word tiered =+    fromJust $ find+        ((==tiered) . tear cfg)+        (S.toList $ tags word)++-- | Tag the file.+tagFile+    :: T.Text           -- ^ Tag indicating unknown words+    -> Disamb+    -> FilePath         -- ^ File to tag (plain format)+    -> IO L.Text+tagFile ign dmb path =+    P.showPlain ign . map onSent <$> P.readPlain ign path+  where+    onSent sent =+        [ choose tok y+        | (tok, y) <- zip sent ys ]+      where+        rs = map (fst . P.fromTok) sent+        xs = map (mapWord parseTag) rs+        ys = map showTag (disamb dmb xs)+        choose tok y = P.choose tok (S.singleton y)+        parseTag = TP.parseTag (tagset dmb)+        showTag  = TP.showTag (tagset dmb)++-- | TODO: Abstract over the format type.+learn+    :: SGD.SgdArgs      -- ^ SGD parameters +    -> FilePath         -- ^ File with positional tagset definition+    -> T.Text        	-- ^ The tag indicating unknown words+    -> TierConf         -- ^ Tiered tagging configuration+    -> FilePath         -- ^ Train file (plain format)+    -> Maybe FilePath   -- ^ Maybe eval file+    -> IO Disamb+learn sgdArgs tagsetPath ign tierConf trainPath evalPath'Maybe = do+    _tagset <- TP.parseTagset tagsetPath <$> readFile tagsetPath+    _crf <- CRF.train sgdArgs+        (schemed _tagset ign tierConf trainPath)+        (schemed _tagset ign tierConf <$> evalPath'Maybe)+    return $ Disamb _crf _tagset tierConf++-- | Schematized data from the plain file.+schemed+    :: TP.Tagset -> T.Text -> TierConf+    -> FilePath -> IO [CRF.SentL Ob (Tag, Tag)]+schemed tagset _ign cfg =+    fmap (map onSent) . P.readPlain _ign+  where+    onSent sent =+        zip (schematize xs') (map mkDist ys')+      where+        (xs, ys) = unzip (map P.fromTok sent)+        xs' = map (mapWord   smash) xs+        ys' = map (mapChoice smash) ys+        smash = tear cfg . parseTag+        parseTag = TP.parseTag tagset+        mkDist = CRF.mkDist . M.toList . M.map unPositive

@@ -1,7 +1,11 @@+{-# LANGUAGE RecordWildCards #-}+ module NLP.Concraft.Morphosyntax ( Word (..)+, mapWord , Sent , Choice+, mapChoice , Positive (unPositive) , (<+>) , mkPositive@@ -9,6 +13,7 @@ , known ) where +import Control.Arrow (first) import Data.Ord (comparing) import Data.List (maximumBy) import qualified Data.Set as S@@ -23,6 +28,11 @@     , tags  :: S.Set t }     deriving (Show, Read, Eq, Ord) +mapWord :: Ord b => (a -> b) -> Word a -> Word b+mapWord f Word{..} = Word+    { orth = orth+    , tags = S.fromList . map f . S.toList $ tags }+ -- | A sentence of 'Word's. type Sent t = [Word t] @@ -37,6 +47,9 @@ (<+>) :: Num a => Positive a -> Positive a -> Positive a Positive x <+> Positive y = Positive (x + y) {-# INLINE (<+>) #-}++mapChoice :: Ord b => (a -> b) -> Choice a -> Choice b+mapChoice f = M.fromListWith (<+>) . map (first f) . M.toList  mkPositive :: (Num a, Ord a) => a -> Positive a mkPositive x

@@ -1,5 +1,5 @@ name:               concraft-version:            0.1.0+version:            0.2.0 synopsis:           Morphosyntactic tagging tool based on constrained CRFs description:     A morphosyntactic tagging tool based on constrained conditional@@ -26,11 +26,14 @@       , crf-chain1-constrained >= 0.1.1 && < 0.2       , monad-ox >= 0.2 && < 0.3       , sgd >= 0.2.2 && < 0.3+      , tagset-positional >= 0.2 && < 0.3+      , crf-chain2-generic >= 0.1.1 && < 0.2      exposed-modules:         NLP.Concraft.Morphosyntax-      , NLP.Concraft.Guess       , NLP.Concraft.Plain+      , NLP.Concraft.Guess+      , NLP.Concraft.Disamb      ghc-options: -Wall -O2 @@ -43,4 +46,11 @@         cmdargs     hs-source-dirs: ., tools     main-is: concraft-guess.hs    +    ghc-options: -Wall -O2 -threaded++executable concraft-disamb+    build-depends:+        cmdargs+    hs-source-dirs: ., tools+    main-is: concraft-disamb.hs         ghc-options: -Wall -O2 -threaded

@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}++import Control.Monad (when)+import System.Console.CmdArgs+import Data.Binary (encodeFile, decodeFile)+import Data.Text.Binary ()+import qualified Data.Set as S+import qualified Numeric.SGD as SGD+import qualified Data.Text as T+import qualified Data.Text.Lazy.IO as L++import NLP.Concraft.Disamb++tierConf :: TierConf+tierConf =+    (tier1, tier2)+  where+    tier1 = Tier True $ S.fromList ["cas", "per"]+    tier2 = Tier False $ S.fromList+        [ "nmb", "gnd", "deg", "asp" , "ngt", "acm"+        , "acn", "ppr", "agg", "vlc", "dot" ]++data Args+  = LearnMode+    { learnPath	    :: FilePath+    , evalPath      :: Maybe FilePath+    , tagsetPath    :: FilePath+    , ignTag        :: String+    , iterNum       :: Double+    , batchSize     :: Int+    , regVar        :: Double+    , gain0         :: Double+    , tau           :: Double+    , outDisamb     :: FilePath }+  | TagMode+    { dataPath      :: FilePath+    , ignTag        :: String+    , inDisamb      :: FilePath }+  deriving (Data, Typeable, Show)++learnMode :: Args+learnMode = LearnMode+    { tagsetPath = def &= argPos 0 &= typ "TAGSET-PATH"+    , ignTag = def &= argPos 1 &= typ "IGN-TAG"+    , learnPath = def &= argPos 2 &= typ "TRAIN-FILE"+    , evalPath = def &= typFile &= help "Evaluation file"+    , 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"+    , outDisamb = def &= typFile &= help "Output Disamb file" }++tagMode :: Args+tagMode = TagMode+    { ignTag = def &= argPos 0 &= typ "IGN-TAG"+    , inDisamb = def &= argPos 1 &= typ "DISAMB-FILE"+    , dataPath = def &= argPos 2 &= typ "INPUT" }++argModes :: Mode (CmdArgs Args)+argModes = cmdArgsMode $ modes [learnMode, tagMode]++main :: IO ()+main = exec =<< cmdArgsRun argModes++exec :: Args -> IO ()++exec LearnMode{..} = do+    dmb <- learn sgdArgs tagsetPath (T.pack ignTag) tierConf learnPath evalPath+    when (not . null $ outDisamb) $ do+        putStrLn $ "\nSaving model in " ++ outDisamb ++ "..."+        encodeFile outDisamb dmb+  where+    sgdArgs = SGD.SgdArgs+        { SGD.batchSize = batchSize+        , SGD.regVar = regVar+        , SGD.iterNum = iterNum+        , SGD.gain0 = gain0+        , SGD.tau = tau }++exec TagMode{..} = do+    dmb <- decodeFile inDisamb+    L.putStr =<< tagFile (T.pack ignTag) dmb dataPath