diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,8 @@ -*-change-log-*- +2.1.0 Sep 2018 + * External configuration of blacklisted tags + 2.0.1 Jul 2018 * External configuration of disambiguation tiers 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: 2.0.2 +version: 2.1.0 synopsis: Morphological tagger for Polish description: A morphological tagger for Polish based on the concraft library. @@ -24,9 +24,9 @@ hs-source-dirs: src build-depends: base >= 4 && < 5 - , concraft >= 0.11 && < 0.12 + , concraft >= 0.12 && < 0.13 , pedestrian-dag >= 0.2 && < 0.3 - , crf-chain1-constrained >= 0.4 && < 0.5 + , crf-chain1-constrained >= 0.5 && < 0.6 , crf-chain2-tiers >= 0.3 && < 0.4 , tagset-positional >= 0.3 && < 0.4 , sgd >= 0.4 && < 0.5 diff --git a/src/NLP/Concraft/Polish/DAG/Format/Base.hs b/src/NLP/Concraft/Polish/DAG/Format/Base.hs --- a/src/NLP/Concraft/Polish/DAG/Format/Base.hs +++ b/src/NLP/Concraft/Polish/DAG/Format/Base.hs @@ -21,7 +21,7 @@ import Data.Monoid (mconcat, mappend) import qualified Data.Map as M import Data.List (intersperse, groupBy) -import Data.Maybe (listToMaybe) +-- import Data.Maybe (listToMaybe) import Data.String (IsString) import Data.Data (Data) import Data.Typeable (Typeable) @@ -37,7 +37,7 @@ import qualified NLP.Concraft.DAG.Morphosyntax as X -- import qualified NLP.Concraft.Polish.DAG2 as C -- import NLP.Concraft.Polish.DAG2 (AnnoSent(..)) -import qualified NLP.Concraft.Polish.DAGSeg as C +-- import qualified NLP.Concraft.Polish.DAGSeg as C import NLP.Concraft.Polish.DAGSeg (AnnoSent(..)) import qualified NLP.Concraft.Polish.Morphosyntax as I @@ -114,9 +114,9 @@ let tailNode = DAG.begsWith edgeID dag headNode = DAG.endsWith edgeID dag X.Seg{..} = DAG.edgeLabel edgeID dag - interp <- map Just (M.toList (X.unWMap tags)) ++ + interpWeight <- map Just (M.toList (X.unWMap tags)) ++ if known word then [] else [Nothing] - return $ case interp of + return $ case interpWeight of Just (interp@Interp{..}, weight) -> buildInterp showCfg tailNode headNode word interp (case probType showCfg of @@ -291,7 +291,7 @@ readTyp :: (Read a) => String -> String -> a readTyp typ x = case readMaybe x of - Just x -> x + Just y -> y Nothing -> error $ "unable to parse \"" ++ x ++ "\" to a " ++ typ -- "Unable to parse <" ++ typ ++ ">" ++ diff --git a/src/NLP/Concraft/Polish/DAG/Morphosyntax.hs b/src/NLP/Concraft/Polish/DAG/Morphosyntax.hs --- a/src/NLP/Concraft/Polish/DAG/Morphosyntax.hs +++ b/src/NLP/Concraft/Polish/DAG/Morphosyntax.hs @@ -43,16 +43,16 @@ import Prelude hiding (Word) import Control.Applicative ((<$>), (<*>)) -- import Control.Arrow (first) -import Control.Monad (guard) -import Data.Binary (Binary, put, get, putWord8, getWord8) +-- import Control.Monad (guard) +import Data.Binary (Binary, put, get) import Data.Aeson -import qualified Data.Aeson as Aeson +-- import qualified Data.Aeson as Aeson import qualified Data.Set as S import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes) +-- import Data.Maybe (catMaybes) import qualified Data.Text as T import qualified Data.Text.Lazy as L -import qualified Data.Tagset.Positional as P +-- import qualified Data.Tagset.Positional as P import Data.DAG (DAG) import qualified Data.DAG as DAG @@ -62,7 +62,7 @@ -- import qualified NLP.Concraft.DAG2 as C import qualified NLP.Concraft.DAG.Morphosyntax as X import qualified NLP.Concraft.DAG.Segmentation as Seg -import qualified NLP.Concraft.Polish.Morphosyntax as R +-- import qualified NLP.Concraft.Polish.Morphosyntax as R import NLP.Concraft.Polish.Morphosyntax (Space(..)) diff --git a/src/NLP/Concraft/Polish/DAG/Server.hs b/src/NLP/Concraft/Polish/DAG/Server.hs --- a/src/NLP/Concraft/Polish/DAG/Server.hs +++ b/src/NLP/Concraft/Polish/DAG/Server.hs @@ -23,7 +23,7 @@ ) where -import Control.Monad.IO.Class (liftIO) +-- import Control.Monad.IO.Class (liftIO) import GHC.Generics diff --git a/src/NLP/Concraft/Polish/DAGSeg.hs b/src/NLP/Concraft/Polish/DAGSeg.hs --- a/src/NLP/Concraft/Polish/DAGSeg.hs +++ b/src/NLP/Concraft/Polish/DAGSeg.hs @@ -10,7 +10,7 @@ ( -- * Types - Tag (..) + Tag -- ** Simplification , simplify4gsr , simplify4dmb @@ -41,22 +41,25 @@ ) where -import Prelude hiding (Word) +import Prelude hiding (Word, pred) import Control.Applicative ((<$>)) -import Control.Arrow (first) +-- import Control.Arrow (first) import Control.Monad (guard) import Data.Maybe (listToMaybe) -import qualified Data.Text.Lazy as L +import qualified Data.Text as T +-- import qualified Data.Text.Lazy as L import qualified Data.Set as S import qualified Data.Map.Strict as M -import Data.Data (Data) -import Data.Typeable (Typeable) +-- import Data.Data (Data) +-- import Data.Typeable (Typeable) import qualified Data.Tagset.Positional as P import qualified Numeric.SGD.Momentum as SGD import qualified Data.DAG as DAG +import qualified Data.CRF.Chain1.Constrained.DAG as CRF + import qualified NLP.Concraft.DAG.Morphosyntax as X import qualified NLP.Concraft.DAG.Morphosyntax.Ambiguous as XA import qualified NLP.Concraft.DAG.Schema as S @@ -209,39 +212,30 @@ -- | Tag the sentence with guessing marginal probabilities. -guess :: C.Concraft Tag -> Sent Tag -> Sent Tag -guess = tagWith (C.guessMarginals . C.guesser) - - --- | Tag the sentence with disambiguation marginal probabilities. -disamb :: C.Concraft Tag -> Sent Tag -> Sent Tag -disamb = tagWith (C.disambMarginals . C.disamb) +guess :: CRF.Config P.Tag -> C.Concraft Tag -> Sent Tag -> Sent Tag +guess cfg = tagWith (C.guessMarginals cfg . C.guesser) --- | Tag the sentence with disambiguation probabilities. -disamb' :: C.Concraft Tag -> D.ProbType -> Sent Tag -> Sent Tag -disamb' crf typ = tagWith (C.disambProbs typ . C.disamb) crf +-- -- | Tag the sentence with disambiguation marginal probabilities. +-- disamb :: C.Concraft Tag -> Sent Tag -> Sent Tag +-- disamb = tagWith (C.disambMarginals . C.disamb) --- | Perform guessing -> trimming -> disambiguation. -tag - :: Int - -- ^ Trimming parameter - -> C.Concraft Tag - -> Sent Tag - -> Sent Tag -tag = tagWith . C.tag +-- -- | Tag the sentence with disambiguation probabilities. +-- disamb' :: C.Concraft Tag -> D.ProbType -> Sent Tag -> Sent Tag +-- disamb' crf typ = tagWith (C.disambProbs typ . C.disamb) crf -- -- | Perform guessing -> trimming -> disambiguation. --- tag' --- :: Int --- -- ^ Trimming parameter --- -> D.ProbType --- -> C.Concraft +-- tag :: +-- Int +-- -- ^ Trimming parameter +-- -> CRF.Config P.Tag +-- -- ^ Blacklist +-- -> C.Concraft Tag -- -> Sent Tag -- -> Sent Tag --- tag' k probTyp = tagWith (C.tag' k probTyp) +-- tag k cfg = tagWith $ C.tag k cfg -- | Tag with the help of a lower-level annotation function. @@ -393,6 +387,8 @@ -- ^ How many morphosyntactic tags should be kept for OOV words , pickPath :: Maybe Seg.PathTyp -- ^ Which path picking method should be used. The function takes the + , blackSet :: S.Set T.Text + -- ^ The set of blacklisted tags } @@ -430,12 +426,19 @@ case pickPath of Just typ -> Seg.pickPath typ sent00 Nothing -> sent00 + + -- Parsed blacklisted tags and CRF config + blackSet' = + S.fromList . map (P.parseTag (C.tagset concraft)) . S.toList $ blackSet + -- Make sure that the blackset is evaluated (otherwise, some malfored + -- tags may be silentely ignored by the tool) + crfCfg = length (show blackSet') `seq` CRF.Config {blackSet = blackSet'} -- We add EOS markers only after guessing, because the possible tags are not -- yet determined for the OOV words. ambiDag = XA.identifyAmbiguousSegments sent0 _guessSent0 = DAG.mapE (addEosMarkers ambiDag) $ - tagWith (C.guess trimParam . C.guesser) concraft sent0 + tagWith (C.guess trimParam crfCfg . C.guesser) concraft sent0 -- Resolve EOS tags based on the segmentation model _guessSent1 = segment . fmap (resolveEOS 0.5) $ tagWith (C.disambProbs D.MaxProbs . C.segmenter) concraft _guessSent0 @@ -507,18 +510,19 @@ putStrLn "\n===== Train guessing model =====" guesser <- G.train (guessConf parBatchSize) trainR'IO evalR'IO - let guess = C.guessSent guessNum guesser + let crfCfg = CRF.Config {blackSet = S.empty} + doGuess = C.guessSent guessNum crfCfg guesser prepSent dag = let ambiDag = XA.identifyAmbiguousSegments dag - in DAG.mapE (addEosMarkers ambiDag) (guess dag) + in DAG.mapE (addEosMarkers ambiDag) (doGuess dag) trainG'IO = map prepSent <$> trainR'IO evalG'IO = map prepSent <$> evalR'IO putStrLn "\n===== Train sentence segmentation model =====" segmenter <- D.train (segmentConf parBatchSize) trainG'IO evalG'IO - let prepSent = segment . fmap (resolveEOS 0.5) - trainS'IO = concatMap prepSent <$> trainG'IO - evalS'IO = concatMap prepSent <$> evalG'IO + let prepSent' = segment . fmap (resolveEOS 0.5) + trainS'IO = concatMap prepSent' <$> trainG'IO + evalS'IO = concatMap prepSent' <$> evalG'IO putStrLn "\n===== Train disambiguation model =====" disamb <- D.train disambConf trainS'IO evalS'IO 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 @@ -19,7 +19,7 @@ , showSent ) where -import Prelude hiding ((<>)) +-- import Prelude hiding ((<>)) import Data.Monoid (Monoid, mappend, mconcat) import Data.Maybe (catMaybes) import Data.List (groupBy) diff --git a/tools/concraft-pl.hs b/tools/concraft-pl.hs --- a/tools/concraft-pl.hs +++ b/tools/concraft-pl.hs @@ -87,6 +87,7 @@ -- , marginals :: Bool , inFile :: Maybe FilePath , outFile :: Maybe FilePath + , blackFile :: Maybe FilePath , probType :: DB.ProbType -- , suppressProbs :: Bool , mayGuessNum :: Maybe Int @@ -98,6 +99,7 @@ } | Server { inModel :: FilePath + , blackFile :: Maybe FilePath , probType :: DB.ProbType , mayGuessNum :: Maybe Int , numericDisamb :: Bool @@ -173,6 +175,7 @@ -- , marginals = False &= help "Tag with marginal probabilities" } , inFile = def &= typFile &= help "Input file (stdin by default)" , outFile = def &= typFile &= help "Output file (stdout by default)" + , blackFile = def &= typFile &= help "File with blacklisted tags, one per line" , probType = DB.Marginals &= help "Type of probabilities" -- , suppressProbs = False &= help "Do not show probabilities" , freqPath = def &= typFile &= help "File with chosen/not-chosen counts" @@ -191,6 +194,7 @@ serverMode :: Concraft serverMode = Server { inModel = def &= argPos 0 &= typ "MODEL-FILE" + , blackFile = def &= typFile &= help "File with blacklisted tags, one per line" , probType = DB.Marginals &= help "Type of probabilities" , mayGuessNum = def &= help "Number of guessed tags for each unknown word" , numericDisamb = False &= help @@ -327,12 +331,16 @@ inp <- DB.parseData <$> case inFile of Nothing -> getContentsUtf8 Just path -> readFileUtf8 path + blackSet <- + case blackFile of + Nothing -> pure S.empty + Just path -> readBlackSet path pathSelection <- case (shortestPath, longestPath, freqPath) of (True, _, _) -> return $ Just Seg.Min (_, True, _) -> return $ Just Seg.Max - (_, _, Just freqPath) -> do - freqMap <- loadFreqMap freqPath + (_, _, Just freqPath') -> do + freqMap <- loadFreqMap freqPath' let conf = Seg.FreqConf { Seg.pickFreqMap = freqMap , Seg.smoothingParam = freqSmoothing @@ -345,6 +353,7 @@ cfg = Pol.AnnoConf { trimParam = guessNum , pickPath = pathSelection + , blackSet = blackSet } out = Pol.annoAll cfg crf <$> inp showCfg = DB.ShowCfg @@ -358,12 +367,17 @@ exec Server{..} = do crf <- Pol.loadModel Pol.simplify4gsr Pol.simplify4dmb inModel + blackSet <- + case blackFile of + Nothing -> pure S.empty + Just path -> readBlackSet path let guessNum = case mayGuessNum of Nothing -> C.guessNum crf Just k -> k cfg = Pol.AnnoConf { trimParam = guessNum , pickPath = Nothing + , blackSet = blackSet } showCfg = DB.ShowCfg { probType = probType @@ -524,6 +538,16 @@ (orth, (readInt chosen, readInt notChosen)) _ -> error $ "loadFreqMap: line incorrectly formatted: " ++ T.unpack line readInt = read . T.unpack + + +--------------------------------------- +-- Blacklist +--------------------------------------- + + +readBlackSet :: FilePath -> IO (S.Set T.Text) +readBlackSet path = + S.fromList . map (L.toStrict . L.strip) . L.lines <$> readFileUtf8 path ---------------------------------------