concraft-pl 0.6.0 → 0.7.0
raw patch · 8 files changed
+348/−130 lines, 8 filesdep ~concraftPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: concraft
API changes (from Hackage documentation)
- NLP.Concraft.Polish: tag' :: MacaPool -> Concraft -> Text -> IO [[Sent Tag]]
- NLP.Concraft.Polish: tagSent :: Concraft -> Sent Tag -> Sent Tag
- NLP.Concraft.Polish.Server: tag :: HostName -> PortID -> Text -> IO [Sent Tag]
- NLP.Concraft.Polish.Server: tag' :: HostName -> PortID -> Text -> IO [[Sent Tag]]
+ NLP.Concraft.Polish: macaPar :: MacaPool -> Text -> IO [Sent Tag]
+ NLP.Concraft.Polish: marginals :: Concraft -> Sent Tag -> Sent Tag
+ NLP.Concraft.Polish.Morphosyntax: select' :: Ord a => [a] -> a -> Seg a -> Seg a
+ NLP.Concraft.Polish.Morphosyntax: selectWMap :: Ord a => WMap a -> Seg a -> Seg a
+ NLP.Concraft.Polish.Request: Config :: Bool -> Config
+ NLP.Concraft.Polish.Request: Doc :: [[Sent Tag]] -> Long
+ NLP.Concraft.Polish.Request: Long :: Text -> Long
+ NLP.Concraft.Polish.Request: Par :: [Sent Tag] -> Short
+ NLP.Concraft.Polish.Request: Request :: t -> Config -> Request t
+ NLP.Concraft.Polish.Request: Short :: Text -> Short
+ NLP.Concraft.Polish.Request: data Long
+ NLP.Concraft.Polish.Request: data Request t
+ NLP.Concraft.Polish.Request: data Short
+ NLP.Concraft.Polish.Request: instance Binary Config
+ NLP.Concraft.Polish.Request: instance Binary Long
+ NLP.Concraft.Polish.Request: instance Binary Short
+ NLP.Concraft.Polish.Request: instance Binary t => Binary (Request t)
+ NLP.Concraft.Polish.Request: long :: (Request Short -> IO a) -> Request Long -> IO [a]
+ NLP.Concraft.Polish.Request: newtype Config
+ NLP.Concraft.Polish.Request: rqBody :: Request t -> t
+ NLP.Concraft.Polish.Request: rqConf :: Request t -> Config
+ NLP.Concraft.Polish.Request: short :: MacaPool -> Concraft -> Request Short -> IO [Sent Tag]
+ NLP.Concraft.Polish.Request: tagProbs :: Config -> Bool
+ NLP.Concraft.Polish.Server: submit :: HostName -> PortID -> Request Short -> IO [Sent Tag]
- NLP.Concraft.Polish: TrainConf :: Tagset -> SgdArgs -> Bool -> Bool -> Int -> Maybe Double -> R0T -> TrainConf
+ NLP.Concraft.Polish: TrainConf :: Tagset -> SgdArgs -> Bool -> Bool -> Int -> R0T -> TrainConf
- NLP.Concraft.Polish: prune :: TrainConf -> Maybe Double
+ NLP.Concraft.Polish: prune :: Double -> Concraft -> Concraft
- NLP.Concraft.Polish: tag :: MacaPool -> Concraft -> Text -> IO [Sent Tag]
+ NLP.Concraft.Polish: tag :: Concraft -> Sent Tag -> Sent Tag
- NLP.Concraft.Polish.Morphosyntax: Seg :: Word -> Map (Interp t) Bool -> Seg t
+ NLP.Concraft.Polish.Morphosyntax: Seg :: Word -> WMap (Interp t) -> Seg t
- NLP.Concraft.Polish.Morphosyntax: interps :: Seg t -> Map (Interp t) Bool
+ NLP.Concraft.Polish.Morphosyntax: interps :: Seg t -> WMap (Interp t)
Files
- changelog +6/−0
- concraft-pl.cabal +3/−2
- src/NLP/Concraft/Polish.hs +62/−36
- src/NLP/Concraft/Polish/Format/Plain.hs +42/−24
- src/NLP/Concraft/Polish/Morphosyntax.hs +25/−17
- src/NLP/Concraft/Polish/Request.hs +116/−0
- src/NLP/Concraft/Polish/Server.hs +9/−25
- tools/concraft-pl.hs +85/−26
changelog view
@@ -1,5 +1,11 @@ -*-change-log-*- +0.7.0 Nov 2013+ * Output guessing results for unknown words + * Allow "--noana" option in the client/server mode+ * Add option to output marginal probabilities+ * Add separate mode for model pruning+ 0.6.0 Nov 2013 * Output wordform instead of "None" as a lemma for unknown words
concraft-pl.cabal view
@@ -1,5 +1,5 @@ name: concraft-pl-version: 0.6.0+version: 0.7.0 synopsis: Morphological tagger for Polish description: A morphological tagger for Polish based on the concraft library.@@ -23,7 +23,7 @@ build-depends: base >= 4 && < 5- , concraft >= 0.8.2 && < 0.9+ , concraft >= 0.9 && < 0.10 , tagset-positional >= 0.3 && < 0.4 , sgd >= 0.3.3 && < 0.4 , containers >= 0.4 && < 0.6@@ -42,6 +42,7 @@ NLP.Concraft.Polish , NLP.Concraft.Polish.Maca , NLP.Concraft.Polish.Morphosyntax+ , NLP.Concraft.Polish.Request , NLP.Concraft.Polish.Server other-modules:
src/NLP/Concraft/Polish.hs view
@@ -11,22 +11,28 @@ -- * Tagging , tag-, tag'-, tagSent+, marginals +-- * Analysis+, macaPar+ -- * Training , TrainConf (..) , train++-- * Pruning+, C.prune++-- -- * Analysis+-- , anaSent+-- , reAnaPar ) where -import qualified Control.Monad.LazyIO as LazyIO import Control.Applicative ((<$>))-import qualified Data.List.Split as Split-import qualified Data.Char as Char-import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Set as S+ import qualified Data.Tagset.Positional as P import qualified Numeric.SGD as SGD @@ -36,6 +42,7 @@ import qualified NLP.Concraft.Guess as G import qualified NLP.Concraft.Disamb as D import qualified NLP.Concraft as C+-- import qualified NLP.Concraft.Analysis as A import NLP.Concraft.Polish.Morphosyntax hiding (tag) import NLP.Concraft.Polish.Maca@@ -83,31 +90,32 @@ ------------------------------------------------- --- | Perform morphological tagging on the input text.-tag :: MacaPool -> C.Concraft -> T.Text -> IO [Sent Tag]-tag pool concraft inp = map (tagSent concraft) <$> macaPar pool inp----- | An alernative tagging function which interprets--- empty lines as paragraph ending markers.--- The function uses lazy IO so it can be used to--- analyse large chunks of data.-tag' :: MacaPool -> C.Concraft -> L.Text -> IO [[Sent Tag]]-tag' pool concraft- = LazyIO.mapM (tag pool concraft . L.toStrict)- . map L.unlines- . Split.splitWhen- (L.all Char.isSpace)- . L.lines+-- | Tag the analysed sentence.+tag :: C.Concraft -> Sent Tag -> Sent Tag+tag concraft sent =+ [ select' gs t seg+ | (seg, gs, t) <- zip3 sent gss ts ]+ where+ tagset = C.tagset concraft+ packed = packSent tagset sent+ tagged = C.tag concraft packed+ gss = map (map showTag . S.toList . fst) tagged+ ts = map (showTag . snd) tagged+ showTag = P.showTag tagset --- | Tag an already analysed sentence.-tagSent :: C.Concraft -> Sent Tag -> Sent Tag-tagSent concraft sent =- let tagset = C.tagset concraft- packed = packSent tagset sent- tags = map (P.showTag tagset) (C.tag concraft packed)- in map (uncurry select) (zip tags sent)+-- | Tag the sentence with marginal probabilities.+marginals :: C.Concraft -> Sent Tag -> Sent Tag+marginals concraft sent+ = map (uncurry selectWMap)+ $ zip wmaps sent+ where+ tagset = C.tagset concraft+ packed = packSent tagset sent+ wmaps = map+ (X.mapWMap showTag)+ (C.marginals concraft packed)+ showTag = P.showTag tagset -------------------------------------------------@@ -115,6 +123,7 @@ ------------------------------------------------- +-- | Training configuration. data TrainConf = TrainConf { -- | Tagset. tagset :: P.Tagset@@ -126,8 +135,6 @@ , onDisk :: Bool -- | Numer of guessed tags for each word. , guessNum :: Int- -- | Disamb model pruning parameter.- , prune :: Maybe Double -- | `G.r0T` parameter. , r0 :: G.R0T } @@ -142,7 +149,7 @@ train TrainConf{..} train0 eval0 = do pool <- newMacaPool 1- let ana = fmap (packSent tagset . concat) . macaPar pool . L.toStrict+ let ana = anaSent tagset pool train1 = map (packSentO tagset) <$> train0 eval1 = map (packSentO tagset) <$> eval0 @@ -152,10 +159,29 @@ where - guessConf = G.TrainConf guessSchemaDefault sgdArgs onDisk r0- 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)++ guessConf = G.TrainConf guessSchemaDefault sgdArgs onDisk r0+ disambConf = D.TrainConf tiersDefault disambSchemaDefault sgdArgs onDisk+++-------------------------------------------------+-- Re-analysis+-------------------------------------------------+++-- | Analyse the given sentence with Maca.+-- anaSent :: MacaPool -> L.Text -> IO (Sent Tag)+anaSent :: P.Tagset -> MacaPool -> L.Text -> IO (X.Sent Word P.Tag)+anaSent tagset pool+ = fmap (packSent tagset . concat)+ . macaPar pool . L.toStrict+++-- -- | Reanalyse the input paragraph (lazy IO).+-- reAnaPar :: P.Tagset -> [SentO Tag] -> IO [Sent Tag]+-- reAnaPar tagset inp = do+-- pool <- newMacaPool 1+-- A.reAnaPar tagset (anaSent pool) inp
src/NLP/Concraft/Polish/Format/Plain.hs view
@@ -14,6 +14,7 @@ , parseSent -- * Printing+, ShowCfg (..) , showPlain , showPara , showSent@@ -28,7 +29,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as L+import qualified Data.Text.Lazy.Read as R+import Text.Printf (printf) +import qualified NLP.Concraft.Morphosyntax as X import NLP.Concraft.Polish.Morphosyntax -- | Parse the text in the plain format.@@ -69,18 +73,22 @@ (_orth, _space) = parseHeader (head xs) ys = map parseInterp (tail xs) _known = not (Nothing `elem` ys)- _interps = M.fromListWith max (catMaybes ys)+ -- _interps = M.fromListWith max (catMaybes ys)+ _interps = X.mkWMap $ catMaybes ys -parseInterp :: L.Text -> Maybe (Interp Tag, Bool)+parseInterp :: L.Text -> Maybe (Interp Tag, Double) parseInterp = doIt . tail . L.splitOn "\t" where doIt [form, tag] | tag == ign = Nothing | otherwise = Just $- (mkInterp form tag, False)- doIt [form, tag, "disamb"] = Just $- (mkInterp form tag, True)+ (mkInterp form tag, 0)+ doIt [form, tag, "disamb"] =+ Just (mkInterp form tag, 1)+ doIt [form, tag, weight] = case R.double weight of+ Left er -> error $ "parseInterp (weight):" ++ show er+ Right w -> Just (mkInterp form tag, fst w) doIt xs = error $ "parseInterp: " ++ show xs mkInterp form tag = Interp (L.toStrict form) (L.toStrict tag) @@ -102,41 +110,51 @@ -- Printing ----------- +-- | Printing configuration.+data ShowCfg = ShowCfg {+ -- | Print weights instead of 'disamb' tags.+ showWsCfg :: Bool }+ -- | Show the plain data.-showPlain :: [[Sent Tag]] -> L.Text-showPlain =- L.intercalate "\n" . map showPara+showPlain :: ShowCfg ->[[Sent Tag]] -> L.Text+showPlain cfg =+ L.intercalate "\n" . map (showPara cfg) -- | Show the paragraph.-showPara :: [Sent Tag] -> L.Text-showPara = L.toLazyText . mconcat . map (\xs -> buildSent xs <> "\n")+showPara :: ShowCfg -> [Sent Tag] -> L.Text+showPara cfg = L.toLazyText . mconcat . map (\xs -> buildSent cfg xs <> "\n") -- | Show the sentence.-showSent :: Sent Tag -> L.Text-showSent xs = L.toLazyText $ buildSent xs+showSent :: ShowCfg -> Sent Tag -> L.Text+showSent cfg xs = L.toLazyText $ buildSent cfg xs -buildSent :: Sent Tag -> L.Builder-buildSent = mconcat . map buildWord+buildSent :: ShowCfg -> Sent Tag -> L.Builder+buildSent cfg = mconcat . map (buildWord cfg) -buildWord :: Seg Tag -> L.Builder-buildWord Seg{..}+buildWord :: ShowCfg -> Seg Tag -> L.Builder+buildWord cfg Seg{..} = L.fromText orth <> "\t" <> buildSpace space <> "\n" <> buildKnown orth known- <> buildInterps (M.toList interps)+ <> buildInterps cfg interps where Word{..} = word -buildInterps :: [(Interp Tag, Bool)] -> L.Builder-buildInterps interps = mconcat+buildInterps :: ShowCfg -> X.WMap (Interp Tag) -> L.Builder+buildInterps ShowCfg{..} interps = mconcat [ "\t" <> buildBase interp <>- "\t" <> buildTag interp <>- if dmb- then "\tdisamb\n"- else "\n"- | (interp, dmb) <- interps ]+ "\t" <> buildTag interp <> buildDmb dmb+ | (interp, dmb) <- M.toList (X.unWMap interps) ] where buildTag = L.fromText . tag buildBase = L.fromText . base+ buildDmb = case showWsCfg of+ True -> \x -> between "\t" "\n"+ $ L.fromString+ $ printf "%.3f" x+ False -> \x -> if x > 0+ then "\tdisamb\n"+ else "\n"+ between x y z = x <> z <> y buildSpace :: Space -> L.Builder buildSpace None = "none"
src/NLP/Concraft/Polish/Morphosyntax.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} -- | Morphosyntax data layer in Polish.@@ -16,6 +17,8 @@ , Interp (..) , Space (..) , select+, select'+, selectWMap -- * Sentence , Sent@@ -36,6 +39,7 @@ import Data.Aeson import Data.Binary (Binary, put, get, putWord8, getWord8) import qualified Data.Aeson as Aeson+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@@ -59,7 +63,7 @@ -- | Interpretations of the token, each interpretation annotated -- with a /disamb/ Boolean value (if 'True', the interpretation -- is correct within the context).- , interps :: M.Map (Interp t) Bool }+ , interps :: X.WMap (Interp t) } deriving (Show, Eq, Ord) @@ -76,7 +80,6 @@ deriving (Show, Eq, Ord) - instance X.Word Word where orth = orth oov = not.known@@ -150,29 +153,31 @@ parseJSON _ = error "parseJSON [Space]" --- | Select one interpretation.+-- | Select one chosen interpretation. select :: Ord a => a -> Seg a -> Seg a-select x = selectWMap (X.mkWMap [(x, 1)])+select = select' [] +-- | Select multiple interpretations and one chosen interpretation.+select' :: Ord a => [a] -> a -> Seg a -> Seg a+select' ys x = selectWMap . X.mkWMap $ (x, 1) : map (,0) ys++ -- | Select interpretations. selectWMap :: Ord a => X.WMap a -> Seg a -> Seg a selectWMap wMap seg = seg { interps = newInterps } where- wSet = M.fromList . map (first tag) . M.toList . interps- asDmb x = if x > 0- then True- else False- newInterps = M.fromList $+ wSet = S.fromList . map tag . M.keys . X.unWMap . interps $ seg+ newInterps = X.mkWMap $ [ case M.lookup (tag interp) (X.unWMap wMap) of- Just x -> (interp, asDmb x)- Nothing -> (interp, False)- | interp <- M.keys (interps seg) ]+ Just x -> (interp, x)+ Nothing -> (interp, 0)+ | interp <- (M.keys . X.unWMap) (interps seg) ] ++ catMaybes- [ if tag `M.member` wSet seg+ [ if tag `S.member` wSet then Nothing- else Just (Interp lemma tag, asDmb x)+ else Just (Interp lemma tag, x) | let lemma = orth $ word seg -- Default base form , (tag, x) <- M.toList (X.unWMap wMap) ] @@ -218,9 +223,12 @@ -- | Convert a segment to a segment from a core library. packSeg_ :: Ord a => Seg a -> X.Seg Word a-packSeg_ Seg{..} = X.Seg word $ X.mkWMap- [ (tag x, if disamb then 1 else 0)- | (x, disamb) <- M.toList interps ]+packSeg_ Seg{..}+ = X.Seg word+ $ X.mkWMap+ $ map (first tag)+ $ M.toList+ $ X.unWMap interps -- | Convert a segment to a segment from a core library.
+ src/NLP/Concraft/Polish/Request.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+++module NLP.Concraft.Polish.Request+(+-- * Request + Request (..)+, Config (..)+-- ** Short+, Short (..)+, short+-- ** Long+, Long (..)+, long+) where+++import Control.Applicative ((<$>), (<*>))+import qualified Control.Monad.LazyIO as LazyIO+import qualified Data.Char as Char+import qualified Data.List.Split as Split+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Binary as B++import NLP.Concraft.Polish+import NLP.Concraft.Polish.Maca+import NLP.Concraft.Polish.Morphosyntax hiding (tag)+++-------------------------------------------------+-- Configuration+-------------------------------------------------+++-- | A request with configuration.+data Request t = Request {+ -- | The actuall request.+ rqBody :: t+ -- | Request configuration.+ , rqConf :: Config }+++instance B.Binary t => B.Binary (Request t) where+ put Request{..} = B.put rqBody >> B.put rqConf+ get = Request <$> B.get <*> B.get+++-- | Tagging configuration.+newtype Config = Config {+ -- | Tag with marginal probabilities.+ tagProbs :: Bool+ } deriving (B.Binary)+++-------------------------------------------------+-- Short request+-------------------------------------------------+++-- | A short request.+data Short+ = Short T.Text+ | Par [Sent Tag]+++instance B.Binary Short where+ put (Short x) = B.putWord8 0 >> B.put x+ put (Par x) = B.putWord8 1 >> B.put x+ get = B.getWord8 >>= \x -> case x of+ 0 -> Short <$> B.get+ _ -> Par <$> B.get+++-- | Process the short request.+short :: MacaPool -> Concraft -> Request Short -> IO [Sent Tag]+short pool concraft Request{..} = case rqBody of+ Short x -> map (tagit concraft) <$> macaPar pool x+ Par x -> return $ map (tagit concraft) x+ where+ tagit = if tagProbs rqConf then marginals else tag+++-------------------------------------------------+-- Long request+-------------------------------------------------+++-- | A request to parse a long text.+data Long+ = Long L.Text+ | Doc [[Sent Tag]]+++instance B.Binary Long where+ put (Long x) = B.putWord8 0 >> B.put x+ put (Doc x) = B.putWord8 1 >> B.put x+ get = B.getWord8 >>= \x -> case x of+ 0 -> Long <$> B.get+ _ -> Doc <$> B.get+++-- | Process the long request given the processor for the+-- short request. +long :: (Request Short -> IO a) -> Request Long -> IO [a]+long handler Request{..} = case rqBody of+ Long inp ->+ LazyIO.mapM f . map L.unlines+ . Split.splitWhen (L.all Char.isSpace)+ . L.lines $ inp+ Doc inp -> LazyIO.mapM g inp+ where+ f x = handler . r $ Short $ L.toStrict x+ g x = handler . r $ Par x+ r x = Request {rqBody = x, rqConf = rqConf}
src/NLP/Concraft/Polish/Server.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module NLP.Concraft.Polish.Server@@ -7,8 +8,7 @@ runConcraftServer -- * Client-, tag-, tag'+, submit ) where @@ -16,18 +16,14 @@ import Control.Monad (forever, void) import Control.Concurrent (forkIO) import System.IO (Handle, hFlush)-import qualified Control.Monad.LazyIO as LazyIO import qualified Network as N-import qualified Data.Char as Char-import qualified Data.List.Split as Split import qualified Data.Binary as B import qualified Data.ByteString.Lazy as BS-import qualified Data.Text as T-import qualified Data.Text.Lazy as L import NLP.Concraft.Polish.Morphosyntax hiding (tag) import NLP.Concraft.Polish.Maca import qualified NLP.Concraft.Polish as C+import qualified NLP.Concraft.Polish.Request as R -------------------------------------------------@@ -42,6 +38,7 @@ forever $ sockHandler pool concraft sock +-- | Read and process short requests from the socket. sockHandler :: MacaPool -> C.Concraft -> N.Socket -> IO () sockHandler pool concraft sock = do (handle, _, _) <- N.accept sock@@ -50,7 +47,7 @@ -- putStrLn "Waiting for input..." inp <- recvMsg handle -- putStr "> " >> T.putStrLn inp- out <- C.tag pool concraft inp+ out <- R.short pool concraft inp -- putStr "No. of sentences: " >> print (length out) sendMsg handle out @@ -60,9 +57,9 @@ ------------------------------------------------- --- | Perform morphological tagging on the input text.-tag :: N.HostName -> N.PortID -> T.Text -> IO [Sent Tag]-tag host port inp = do+-- | Submit the given request.+submit :: N.HostName -> N.PortID -> R.Request R.Short -> IO [Sent Tag]+submit host port inp = do handle <- N.connectTo host port -- putStrLn "Connection established" -- putStr "Send request: " >> T.putStrLn inp@@ -70,21 +67,8 @@ recvMsg handle --- | An alernative tagging function which interprets--- empty lines as paragraph ending markers.--- The function uses lazy IO so it can be used to--- analyse large chunks of data.-tag' :: N.HostName -> N.PortID -> L.Text -> IO [[Sent Tag]]-tag' host port- = LazyIO.mapM (tag host port . L.toStrict)- . map L.unlines- . Split.splitWhen- (L.all Char.isSpace)- . L.lines-- ---------------------------------------------------- Messages+-- Communication -------------------------------------------------
tools/concraft-pl.hs view
@@ -19,6 +19,7 @@ import qualified NLP.Concraft.Polish.Maca as Maca import qualified NLP.Concraft.Polish as C+import qualified NLP.Concraft.Polish.Request as R 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@@ -37,7 +38,7 @@ --------------------------------------- --- | Data formats. +-- | Data formats. data Format = Plain deriving (Data, Typeable, Show) @@ -60,20 +61,22 @@ , gain0 :: Double , tau :: Double , disk :: Bool- , prune :: Maybe Double , outModel :: FilePath , guessNum :: Int , r0 :: Guess.R0T } | Tag { inModel :: FilePath , noAna :: Bool- , format :: Format }+ , format :: Format+ , marginals :: Bool } -- , guessNum :: Int } | Server { inModel :: FilePath , port :: Int } | Client- { format :: Format+ { noAna :: Bool+ , format :: Format+ , marginals :: Bool , host :: String , port :: Int } | Compare@@ -81,6 +84,12 @@ , refPath :: FilePath , otherPath :: FilePath , format :: Format }+ | Prune+ { inModel :: FilePath+ , outModel :: FilePath+ , threshold :: Double }+-- | ReAna+-- { format :: Format } deriving (Data, Typeable, Show) @@ -98,7 +107,6 @@ , 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" , r0 = Guess.OovChosen &= help "R0 construction method" }@@ -106,9 +114,10 @@ tagMode :: Concraft tagMode = Tag- { inModel = def &= argPos 0 &= typ "MODEL-FILE"- , noAna = False &= help "Do not analyse input text"- , format = enum [Plain &= help "Plain input format"] }+ { inModel = def &= argPos 0 &= typ "MODEL-FILE"+ , noAna = False &= help "Do not analyse input text"+ , format = enum [Plain &= help "Plain format"]+ , marginals = False &= help "Tag with marginal probabilities" } -- , guessNum = 10 &= help "Number of guessed tags for each unknown word" } @@ -120,9 +129,11 @@ clientMode :: Concraft clientMode = Client- { port = portDefault &= help "Port number"- , host = "localhost" &= help "Server host name"- , format = enum [Plain &= help "Plain output format"] }+ { noAna = False &= help "Do not perform reanalysis"+ , port = portDefault &= help "Port number"+ , host = "localhost" &= help "Server host name"+ , format = enum [Plain &= help "Plain output format"]+ , marginals = False &= help "Tag with marginal probabilities" } compareMode :: Concraft@@ -130,12 +141,25 @@ { refPath = def &= argPos 1 &= typ "REFERENCE-FILE" , otherPath = def &= argPos 2 &= typ "OTHER-FILE" , tagsetPath = def &= typFile &= help "Tagset definition file"- , format = enum [Plain &= help "Plain input format"] }+ , format = enum [Plain &= help "Plain format"] } +pruneMode :: Concraft+pruneMode = Prune+ { inModel = def &= argPos 0 &= typ "INPUT-MODEL"+ , outModel = def &= argPos 1 &= typ "OUTPUT-MODEL"+ , threshold = 0.05 &=+ help "Remove disambiguation features below the threshold" }+++-- reAnaMode :: Concraft+-- reAnaMode = ReAna+-- { format = enum [Plain &= help "Plain format"] }++ argModes :: Mode (CmdArgs Concraft) argModes = cmdArgsMode $ modes- [trainMode, tagMode, serverMode, clientMode, compareMode]+ [trainMode, tagMode, serverMode, clientMode, compareMode, pruneMode] &= summary concraftDesc &= program "concraft-pl" @@ -176,20 +200,26 @@ , reana = not noAna , onDisk = disk , guessNum = guessNum- , prune = prune , r0 = r0 } exec Tag{..} = do- cnft <- C.loadModel inModel+ cft <- C.loadModel inModel pool <- Maca.newMacaPool numCapabilities- 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+ inp <- L.getContents+ out <- R.long (R.short pool cft) $ rq $ if noAna+ then R.Doc $ parseText format inp+ else R.Long inp+ L.putStr $ showData showCfg out+ where+ rq x = R.Request+ { R.rqBody = x+ , R.rqConf = rqConf }+ rqConf = R.Config+ { R.tagProbs = marginals }+ showCfg = ShowCfg+ { formatCfg = format+ , showWsCfg = marginals } exec Server{..} = do@@ -204,8 +234,20 @@ exec Client{..} = do let portNum = N.PortNumber $ fromIntegral port- out <- S.tag' host portNum =<< L.getContents- L.putStr $ showData format out+ inp <- L.getContents+ out <- R.long (S.submit host portNum) $ rq $ if noAna+ then R.Doc $ parseText format inp+ else R.Long inp+ L.putStr $ showData showCfg out+ where+ rq x = R.Request+ { R.rqBody = x+ , R.rqConf = rqConf }+ rqConf = R.Config+ { R.tagProbs = marginals }+ showCfg = ShowCfg+ { formatCfg = format+ , showWsCfg = marginals } exec Compare{..} = do@@ -222,6 +264,16 @@ putStrLn $ "Weak accuracy lower bound: " ++ show (Acc.accuracy s) +exec Prune{..} = do+ cft <- C.loadModel inModel+ C.saveModel outModel $ C.prune threshold cft+++-- exec ReAna{..} = do+-- inp <- parseText format <$> L.getContents+-- out <- showData format <$> ++ --------------------------------------- -- Reading files ---------------------------------------@@ -272,5 +324,12 @@ --------------------------------------- -showData :: Format -> [[X.Sent X.Tag]] -> L.Text-showData Plain = P.showPlain+data ShowCfg = ShowCfg {+ -- | The format used.+ formatCfg :: Format+ -- | Show weights?+ , showWsCfg :: Bool }+++showData :: ShowCfg -> [[X.Sent X.Tag]] -> L.Text+showData ShowCfg{..} = P.showPlain (P.ShowCfg {P.showWsCfg = showWsCfg})