diff --git a/concraft-pl.cabal b/concraft-pl.cabal --- a/concraft-pl.cabal +++ b/concraft-pl.cabal @@ -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 diff --git a/src/NLP/Concraft/Polish.hs b/src/NLP/Concraft/Polish.hs --- a/src/NLP/Concraft/Polish.hs +++ b/src/NLP/Concraft/Polish.hs @@ -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) diff --git a/src/NLP/Concraft/Polish/Format/Plain.hs b/src/NLP/Concraft/Polish/Format/Plain.hs --- a/src/NLP/Concraft/Polish/Format/Plain.hs +++ b/src/NLP/Concraft/Polish/Format/Plain.hs @@ -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 diff --git a/src/NLP/Concraft/Polish/Maca.hs b/src/NLP/Concraft/Polish/Maca.hs --- a/src/NLP/Concraft/Polish/Maca.hs +++ b/src/NLP/Concraft/Polish/Maca.hs @@ -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 diff --git a/src/NLP/Concraft/Polish/Server.hs b/src/NLP/Concraft/Polish/Server.hs --- a/src/NLP/Concraft/Polish/Server.hs +++ b/src/NLP/Concraft/Polish/Server.hs @@ -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 [] ------------------------------------------------- diff --git a/tools/concraft-pl.hs b/tools/concraft-pl.hs --- a/tools/concraft-pl.hs +++ b/tools/concraft-pl.hs @@ -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