concraft-pl 0.1.0 → 0.2.0

raw patch · 6 files changed

+193/−81 lines, 6 filesdep +lazy-iodep ~concraftdep ~sgdPVP ok

version bump matches the API change (PVP)

Dependencies added: lazy-io

Dependency ranges changed: concraft, sgd

API changes (from Hackage documentation)

Files

• concraft-pl.cabal +5/−4
• src/NLP/Concraft/Polish.hs +46/−26
• src/NLP/Concraft/Polish/Format/Plain.hs +25/−20
• src/NLP/Concraft/Polish/Maca.hs +7/−5
• src/NLP/Concraft/Polish/Server.hs +2/−10
• tools/concraft-pl.hs +108/−16

@@ -1,5 +1,5 @@ name:               concraft-pl-version:            0.1.0+version:            0.2.0 synopsis:           Morphological tagger for Polish description:     A morphological tagger for Polish based on the concraft library.@@ -19,9 +19,9 @@      build-depends:         base >= 4 && < 5-      , concraft >= 0.5 && < 0.6+      , concraft >= 0.7.3 && < 0.8       , tagset-positional >= 0.3 && < 0.4-      , sgd >= 0.2.2 && < 0.3+      , sgd >= 0.3.2 && < 0.4       , containers       , bytestring       , text@@ -31,6 +31,7 @@       , mtl       , transformers       , network+      , lazy-io      exposed-modules:         NLP.Concraft.Polish@@ -51,5 +52,5 @@     build-depends:         cmdargs >= 0.10 && < 0.11     hs-source-dirs: src, tools-    main-is: concraft-pl.hs    +    main-is: concraft-pl.hs     ghc-options: -Wall -O2 -threaded -rtsopts

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}   module NLP.Concraft.Polish@@ -14,11 +15,12 @@ , tagSent  -- * Training+, TrainConf (..) , train ) where  -import           System.IO.Unsafe (unsafeInterleaveIO)+import qualified Control.Monad.LazyIO as LazyIO import           Control.Applicative ((<$>)) import qualified Data.Text as T import qualified Data.Text.Lazy as L@@ -26,6 +28,7 @@ import qualified Data.Tagset.Positional as P import qualified Numeric.SGD as SGD +import qualified NLP.Concraft.Morphosyntax as X import qualified NLP.Concraft.Schema as S import           NLP.Concraft.Schema (SchemaConf(..), entry, entryWith) import qualified NLP.Concraft.Guess as G@@ -42,8 +45,8 @@   -- | Default configuration for the guessing observation schema.-guessConfDefault :: SchemaConf-guessConfDefault = S.nullConf+guessSchemaDefault :: SchemaConf+guessSchemaDefault = S.nullConf     { lowPrefixesC  = entryWith [1, 2]      [0]     , lowSuffixesC  = entryWith [1, 2]      [0]     , knownC        = entry                 [0]@@ -51,8 +54,8 @@   -- | Default configuration for the guessing observation schema.-disambConfDefault :: SchemaConf-disambConfDefault = S.nullConf+disambSchemaDefault :: SchemaConf+disambSchemaDefault = S.nullConf     { lowOrthC      = entry                         [-1, 0, 1]     , lowPrefixesC  = oov $ entryWith [1, 2, 3]     [0]     , lowSuffixesC  = oov $ entryWith [1, 2, 3]     [0]@@ -89,7 +92,7 @@ -- analyse large chunks of data. tag' :: MacaPool -> C.Concraft -> L.Text -> IO [[Sent Tag]] tag' pool concraft-    = lazyMapM (tag pool concraft . L.toStrict)+    = LazyIO.mapM (tag pool concraft . L.toStrict)     . map L.strip     . L.splitOn "\n\n" @@ -103,34 +106,51 @@     in  embedSent inp $ map (P.showTag tagset) xs  -lazyMapM :: (a -> IO b) -> [a] -> IO [b]-lazyMapM f (x:xs) = do-    y <- f x-    ys <- unsafeInterleaveIO $ lazyMapM f xs-    return (y:ys)-lazyMapM _ [] = return []-- ------------------------------------------------- -- Training -------------------------------------------------  +data TrainConf = TrainConf {+    -- | Tagset.+      tagset    :: P.Tagset+    -- | SGD parameters.+    , sgdArgs   :: SGD.SgdArgs+    -- | Perform reanalysis.+    , reana     :: Bool+    -- | Store SGD dataset on disk.+    , onDisk    :: Bool+    -- | Numer of guessed tags for each word.+    , guessNum  :: Int+    -- | Disamb model pruning parameter.+    , prune     :: Maybe Double }++ -- | Train concraft model. -- TODO: It should be possible to supply the two training procedures with -- different SGD arguments. train-    :: SGD.SgdArgs      -- ^ SGD parameters-    -> P.Tagset         -- ^ Tagset-    -> Int              -- ^ Numer of guessed tags for each word -    -> [SentO Tag]      -- ^ Training data-    -> Maybe [SentO Tag] -- ^ Maybe evaluation data+    :: TrainConf+    -> IO [SentO Tag]      -- ^ Training data+    -> IO [SentO Tag]      -- ^ Evaluation data     -> IO C.Concraft-train sgdArgs tagset guessNum train0 eval0 = do+train TrainConf{..} train0 eval0 = do+     pool <- newMacaPool 1-    let guessConf  = G.TrainConf guessConfDefault sgdArgs-        disambConf = D.TrainConf tiersDefault disambConfDefault sgdArgs-        ana = fmap (packSentTag tagset . concat) . macaPar pool . L.toStrict-    C.train tagset ana guessNum guessConf disambConf-        (map (packSentTagO tagset)     train0)-        (map (packSentTagO tagset) <$> eval0)+    let ana = fmap (packSentTag tagset . concat) . macaPar pool . L.toStrict+        train1 = map (packSentTagO tagset) <$> train0+        eval1  = map (packSentTagO tagset) <$> eval0++    if reana+        then doReana ana train1 eval1+        else noReana     train1 eval1++  where++    guessConf  = G.TrainConf guessSchemaDefault sgdArgs onDisk+    disambConf = D.TrainConf tiersDefault disambSchemaDefault+        sgdArgs onDisk prune++    doReana ana   = C.reAnaTrain tagset ana guessNum guessConf disambConf+    noReana tr ev = C.train tagset guessNum guessConf disambConf +        (map X.segs <$> tr) (map X.segs <$> ev)

@@ -10,13 +10,12 @@ ( -- * Parsing   parsePlain-, parsePlainO-, parsePar+, parsePara , parseSent  -- * Printing , showPlain-, showPar+, showPara , showSent ) where @@ -24,6 +23,7 @@ import           Data.Maybe (catMaybes) import           Data.List (groupBy) import           Data.String (IsString)+import qualified Data.Char as C import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L@@ -34,23 +34,28 @@ noneBase :: T.Text noneBase = "None" --- | Parse the text in the plain format given the /oov/ tag.--- Original sentences will be restored using the `withOrig`--- function.  Plain format doesn't preserve original,--- textual representation of individual sentences.-parsePlainO :: L.Text -> [[SentO Tag]]-parsePlainO = map (map withOrig) . parsePlain---- | Parse the text in the plain format given the /oov/ tag.--- TODO: Handling spaces between paragraphs and sentences has to be--- smarter than that.+-- | Parse the text in the plain format. parsePlain :: L.Text -> [[Sent Tag]]-parsePlain = map parsePar . filter (not.L.null) . L.splitOn "\n\n\n"+parsePlain =+    map parsePara' . groupBy f . L.splitOn "\n\n"+  where+    f _ xs = case L.uncons xs of+        Nothing     -> False+        Just (x, _) -> not (C.isSpace x) -parsePar :: L.Text -> [Sent Tag]-parsePar = map parseSent . filter (not.L.null) . L.splitOn "\n\n"+-- | Parse the paragraph in the plain format.+parsePara :: L.Text -> [Sent Tag]+parsePara = parsePara' . L.splitOn "\n\n" --- | Parse the sentence in the plain format given the /oov/ tag.+-- | Parse paragraph already divided into sentence chunks.+parsePara' :: [L.Text] -> [Sent Tag]+parsePara' = map (parseSent . L.strip) . filter (not.isEmpty)++-- | Identify empty chunks of text.+isEmpty :: L.Text -> Bool+isEmpty = L.all C.isSpace++-- | Parse the sentence in the plain format. parseSent :: L.Text -> Sent Tag parseSent     = map parseWord@@ -107,11 +112,11 @@ -- | Show the plain data. showPlain :: [[Sent Tag]] -> L.Text showPlain =-    L.intercalate "\n" . map showPar+    L.intercalate "\n" . map showPara  -- | Show the paragraph.-showPar :: [Sent Tag] -> L.Text-showPar = L.toLazyText . mconcat  . map (\xs -> buildSent xs <> "\n")+showPara :: [Sent Tag] -> L.Text+showPara = L.toLazyText . mconcat  . map (\xs -> buildSent xs <> "\n")  -- | Show the sentence. showSent :: Sent Tag -> L.Text

@@ -16,7 +16,7 @@   import           Control.Applicative ((<$>))-import           Control.Monad (void, forever, guard, replicateM)+import           Control.Monad (void, forever, guard, replicateM, unless) import           Control.Concurrent import           Control.Exception import           System.Process@@ -77,10 +77,12 @@                                      , std_err = CreatePipe }      let excHandler = do-            -- TODO: Is it possible, that `errh` handle is closed?-            -- If so, appropriate exception should be handled.-            err <- hGetContents errh-            putStr "Maca error: " >> putStrLn err+            let tryIO = try :: IO a -> IO (Either IOException a)+            void $ tryIO $ do+                err <- hGetContents errh+                unless (all C.isSpace err) $ do+                    putStr "Maca error: "+                    putStrLn err             hClose inh; hClose outh; hClose errh             terminateProcess pid             waitForProcess pid

@@ -16,7 +16,7 @@ import           Control.Monad (forever, void) import           Control.Concurrent (forkIO) import           System.IO (Handle, hFlush)-import           System.IO.Unsafe (unsafeInterleaveIO)+import qualified Control.Monad.LazyIO as LazyIO import qualified Network as N import qualified Data.Binary as B import qualified Data.ByteString.Lazy as BS@@ -74,17 +74,9 @@ -- analyse large chunks of data. tag' :: N.HostName -> N.PortID -> L.Text -> IO [[Sent Tag]] tag' host port-    = lazyMapM (tag host port . L.toStrict)+    = LazyIO.mapM (tag host port . L.toStrict)     . map L.strip     . L.splitOn "\n\n"---lazyMapM :: (a -> IO b) -> [a] -> IO [b]-lazyMapM f (x:xs) = do-    y <- f x-    ys <- unsafeInterleaveIO $ lazyMapM f xs-    return (y:ys)-lazyMapM _ [] = return []   -------------------------------------------------

@@ -14,13 +14,18 @@ import           Data.Tagset.Positional (parseTagset) import           GHC.Conc (numCapabilities) +import qualified NLP.Concraft.Morphosyntax.Accuracy as Acc+ import qualified NLP.Concraft.Polish.Maca as Maca import qualified NLP.Concraft.Polish as C import qualified NLP.Concraft.Polish.Server as S import qualified NLP.Concraft.Polish.Morphosyntax as X import qualified NLP.Concraft.Polish.Format.Plain as P +import           Paths_concraft_pl (version)+import           Data.Version (showVersion) + -- | Default port number. portDefault :: Int portDefault = 10089@@ -35,22 +40,31 @@ data Format = Plain deriving (Data, Typeable, Show)  +-- | A description of the Concraft-pl tool+concraftDesc :: String+concraftDesc = "Concraft-pl " ++ showVersion version++ data Concraft   = Train     { trainPath	    :: FilePath     , evalPath      :: Maybe FilePath     , format        :: Format     , tagsetPath    :: FilePath+    , noAna         :: Bool     -- , discardHidden :: Bool     , iterNum       :: Double     , batchSize     :: Int     , regVar        :: Double     , gain0         :: Double     , tau           :: Double+    , disk          :: Bool+    , prune         :: Maybe Double     , outModel      :: FilePath     , guessNum      :: Int }   | Tag     { inModel       :: FilePath+    , noAna         :: Bool     , format        :: Format }     -- , guessNum      :: Int }   | Server@@ -60,6 +74,11 @@     { format        :: Format     , host          :: String     , port          :: Int }+  | Compare+    { tagsetPath    :: FilePath+    , refPath       :: FilePath+    , otherPath     :: FilePath+    , format        :: Format }   deriving (Data, Typeable, Show)  @@ -69,20 +88,24 @@     , trainPath = def &= argPos 1 &= typ "TRAIN-FILE"     , evalPath = def &= typFile &= help "Evaluation file"     , format = enum [Plain &= help "Plain format"]+    , noAna = False &= help "Do not perform reanalysis"     -- , discardHidden = False &= help "Discard hidden features"     , 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"+    , disk = False &= help "Store SGD dataset on disk"+    , prune = Nothing &= help "Disambiguation model pruning parameter"     , outModel = def &= typFile &= help "Output Model file"     , guessNum = 10 &= help "Number of guessed tags for each unknown word" }   tagMode :: Concraft tagMode = Tag-    { inModel = def &= argPos 0 &= typ "MODEL-FILE"-    , format  = enum [Plain &= help "Use plain format for output"] }+    { inModel   = def &= argPos 0 &= typ "MODEL-FILE"+    , noAna     = False &= help "Do not analyse input text"+    , format    = enum [Plain &= help "Plain input format"] }     -- , guessNum = 10 &= help "Number of guessed tags for each unknown word" }  @@ -96,11 +119,22 @@ clientMode = Client     { port   = portDefault &= help "Port number"     , host   = "localhost" &= help "Server host name"-    , format = enum [Plain &= help "Use plain format for output"] }+    , format = enum [Plain &= help "Plain output format"] }  +compareMode :: Concraft+compareMode = Compare+    { tagsetPath = def &= argPos 0 &= typ "TAGSET-PATH"+    , refPath   = def &= argPos 1 &= typ "REFERENCE-FILE"+    , otherPath = def &= argPos 2 &= typ "OTHER-FILE"+    , format  = enum [Plain &= help "Plain input format"] }++ argModes :: Mode (CmdArgs Concraft)-argModes = cmdArgsMode $ modes [trainMode, tagMode, serverMode, clientMode]+argModes = cmdArgsMode $ modes+    [trainMode, tagMode, serverMode, clientMode, compareMode]+    &= summary concraftDesc+    &= program "concraft-pl"   ---------------------------------------@@ -117,9 +151,9 @@  exec Train{..} = do     tagset <- parseTagset tagsetPath <$> readFile tagsetPath-    train0 <- parseData  format trainPath-    eval0  <- parseData' format evalPath-    concraft <- C.train sgdArgs tagset guessNum train0 eval0 +    let train0 = parseFileO  format trainPath+    let eval0  = parseFileO' format evalPath+    concraft <- C.train (trainConf tagset) train0 eval0     unless (null outModel) $ do         putStrLn $ "\nSaving model in " ++ outModel ++ "..."         C.saveModel outModel concraft@@ -130,12 +164,24 @@         , SGD.iterNum = iterNum         , SGD.gain0 = gain0         , SGD.tau = tau }+    trainConf tagset = C.TrainConf+        { tagset    = tagset +        , sgdArgs   = sgdArgs+        , reana     = not noAna+        , onDisk    = disk+        , guessNum  = guessNum+        , prune     = prune }   exec Tag{..} = do-    concraft <- C.loadModel inModel+    cnft <- C.loadModel inModel     pool <- Maca.newMacaPool numCapabilities-    out <- C.tag' pool concraft =<< L.getContents+    inp  <- L.getContents+    out  <- if not noAna+        then C.tag' pool cnft inp+        else return $+           let out = parseText format inp+           in  map (map (C.tagSent cnft)) out     L.putStr $ showData format out  @@ -155,19 +201,65 @@     L.putStr $ showData format out  +exec Compare{..} = do+    tagset <- parseTagset tagsetPath <$> readFile tagsetPath+    let convert = map (X.packSegTag tagset) . concat+    xs <- convert <$> parseFile format refPath+    ys <- convert <$> parseFile format otherPath+    let s = Acc.weakLB tagset xs ys+    putStrLn $ "Number of segments in reference file: " ++ show (Acc.gold s)+    putStrLn $ "Number of correct tags: " ++ show (Acc.good s)+    putStrLn $ "Weak accuracy lower bound: " ++ show (Acc.accuracy s)++ ------------------------------------------ Parsing and showing+-- Reading files ---------------------------------------  -parseData' :: Format -> Maybe FilePath -> IO (Maybe [X.SentO X.Tag])-parseData' format path = case path of-    Nothing -> return Nothing-    Just pt -> Just <$> parseData format pt+parseFileO' :: Format -> Maybe FilePath -> IO [X.SentO X.Tag]+parseFileO' format path = case path of+    Nothing -> return []+    Just pt -> parseFileO format pt  -parseData :: Format -> FilePath -> IO [X.SentO X.Tag]-parseData Plain path = concat . P.parsePlainO <$> L.readFile path+parseFileO :: Format -> FilePath -> IO [X.SentO X.Tag]+parseFileO format path = parseParaO format <$> L.readFile path+++parseFile :: Format -> FilePath -> IO [X.Sent X.Tag]+parseFile format path = parsePara format <$> L.readFile path+++---------------------------------------+-- Parsing text+---------------------------------------+++-- parseTextO :: Format -> L.Text -> [[X.SentO X.Tag]]+-- parseTextO format = map (map X.withOrig) . parseText format+++parseParaO :: Format -> L.Text -> [X.SentO X.Tag]+parseParaO format = map X.withOrig . parsePara format+++---------------------------------------+-- Parsing (format dependent functions)+---------------------------------------+++parseText :: Format -> L.Text -> [[X.Sent X.Tag]]+parseText Plain = P.parsePlain+++parsePara :: Format -> L.Text -> [X.Sent X.Tag]+parsePara Plain = P.parsePara+++---------------------------------------+-- Showing data+---------------------------------------   showData :: Format -> [[X.Sent X.Tag]] -> L.Text