concraft-pl 0.2.1 → 0.3.0
raw patch · 4 files changed
+91/−65 lines, 4 filesdep ~concraft
Dependency ranges changed: concraft
Files
- concraft-pl.cabal +2/−2
- src/NLP/Concraft/Polish.hs +11/−10
- src/NLP/Concraft/Polish/Morphosyntax.hs +68/−47
- tools/concraft-pl.hs +10/−6
concraft-pl.cabal view
@@ -1,5 +1,5 @@ name: concraft-pl-version: 0.2.1+version: 0.3.0 synopsis: Morphological tagger for Polish description: A morphological tagger for Polish based on the concraft library.@@ -19,7 +19,7 @@ build-depends: base >= 4 && < 5- , concraft >= 0.7.3 && < 0.8+ , concraft >= 0.8.0 && < 0.9 , tagset-positional >= 0.3 && < 0.4 , sgd >= 0.3.2 && < 0.4 , containers
src/NLP/Concraft/Polish.hs view
@@ -99,11 +99,11 @@ -- | Tag an already analysed sentence. tagSent :: C.Concraft -> Sent Tag -> Sent Tag-tagSent concraft inp =+tagSent concraft sent = let tagset = C.tagset concraft- packed = packSentTag tagset inp- xs = C.tag concraft packed- in embedSent inp $ map (P.showTag tagset) xs+ packed = packSent tagset sent+ tags = map (P.showTag tagset) (C.tag concraft packed)+ in map (uncurry select) (zip tags sent) -------------------------------------------------@@ -123,8 +123,9 @@ -- | Numer of guessed tags for each word. , guessNum :: Int -- | Disamb model pruning parameter.- , prune :: Maybe Double }-+ , prune :: Maybe Double+ -- | `G.r0T` parameter.+ , r0 :: G.R0T } -- | Train concraft model. -- TODO: It should be possible to supply the two training procedures with@@ -137,9 +138,9 @@ train TrainConf{..} train0 eval0 = do pool <- newMacaPool 1- let ana = fmap (packSentTag tagset . concat) . macaPar pool . L.toStrict- train1 = map (packSentTagO tagset) <$> train0- eval1 = map (packSentTagO tagset) <$> eval0+ let ana = fmap (packSent tagset . concat) . macaPar pool . L.toStrict+ train1 = map (packSentO tagset) <$> train0+ eval1 = map (packSentO tagset) <$> eval0 if reana then doReana ana train1 eval1@@ -147,7 +148,7 @@ where - guessConf = G.TrainConf guessSchemaDefault sgdArgs onDisk+ guessConf = G.TrainConf guessSchemaDefault sgdArgs onDisk r0 disambConf = D.TrainConf tiersDefault disambSchemaDefault sgdArgs onDisk prune
src/NLP/Concraft/Polish/Morphosyntax.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} + -- | Morphosyntax data layer in Polish. + module NLP.Concraft.Polish.Morphosyntax ( -- * Tag@@ -13,6 +15,7 @@ , Word (..) , Interp (..) , Space (..)+, select -- * Sentence , Sent@@ -21,14 +24,12 @@ , withOrig -- * Conversion-, packSegTag , packSeg-, packSentTag-, packSentTagO , packSent-, embedSent+, packSentO ) where + import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first) import Data.Maybe (catMaybes)@@ -42,14 +43,17 @@ import qualified NLP.Concraft.Morphosyntax as X + -- | A textual representation of a morphosyntactic tag. type Tag = T.Text + -------------------------------- -- Segment -------------------------------- --- | A segment.++-- | A segment consists of a word and a set of morphosyntactic interpretations. data Seg t = Seg { word :: Word -- | Interpretations of the token, each interpretation annotated@@ -58,9 +62,11 @@ , interps :: M.Map (Interp t) Bool } deriving (Show, Eq, Ord) + instance (Ord t, Binary t) => Binary (Seg t) where put Seg{..} = put word >> put interps get = Seg <$> get <*> get+ -- | A word. data Word = Word@@ -69,16 +75,20 @@ , known :: Bool } deriving (Show, Eq, Ord) ++ instance X.Word Word where orth = orth oov = not.known + instance ToJSON Word where toJSON Word{..} = object [ "orth" .= orth , "space" .= space , "known" .= known ] + instance FromJSON Word where parseJSON (Object v) = Word <$> v .: "orth"@@ -86,21 +96,25 @@ <*> v .: "known" parseJSON _ = error "parseJSON [Word]" + instance Binary Word where put Word{..} = put orth >> put space >> put known get = Word <$> get <*> get <*> get --- | An interpretation.++-- | A morphosyntactic interpretation. -- TODO: Should we allow `base` to be `Nothing`? data Interp t = Interp { base :: Maybe T.Text , tag :: t } deriving (Show, Eq, Ord) + instance (Ord t, Binary t) => Binary (Interp t) where put Interp{..} = put base >> put tag get = Interp <$> get <*> get + -- | No space, space or newline. -- TODO: Perhaps we should use a bit more informative data type. data Space@@ -109,6 +123,7 @@ | NewLine deriving (Show, Eq, Ord) + instance Binary Space where put x = case x of None -> putWord8 1@@ -119,12 +134,14 @@ 2 -> Space _ -> NewLine + instance ToJSON Space where toJSON x = Aeson.String $ case x of None -> "none" Space -> "space" NewLine -> "newline" + instance FromJSON Space where parseJSON (Aeson.String x) = return $ case x of "none" -> None@@ -133,18 +150,48 @@ _ -> error "parseJSON [Space]" parseJSON _ = error "parseJSON [Space]" ++-- | Select one interpretation.+select :: Ord a => a -> Seg a -> Seg a+select x = selectWMap (X.mkWMap [(x, 1)])+++-- | 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 $+ [ case M.lookup (tag interp) (X.unWMap wMap) of+ Just x -> (interp, asDmb x)+ Nothing -> (interp, False)+ | interp <- M.keys (interps seg) ]+ ++ catMaybes+ [ if tag `M.member` wSet seg+ then Nothing+ else Just (Interp Nothing tag, asDmb x)+ | (tag, x) <- M.toList (X.unWMap wMap) ]++ -------------------------------- -- Sentence -------------------------------- + -- | A sentence. type Sent t = [Seg t] + -- | A sentence. data SentO t = SentO { segs :: [Seg t] , orig :: L.Text } + -- | Restore textual representation of a sentence. -- The function is not very accurate, it could be improved -- if we enrich representation of a space.@@ -156,64 +203,38 @@ spaceStr NewLine = "\n" in L.fromChunks . concatMap (wordStr . word) + -- | Use `restore` to translate `Sent` to a `SentO`. withOrig :: Sent t -> SentO t withOrig s = SentO { segs = s , orig = restore s } + --------------------------- -- Conversion --------------------------- --- | Convert a segment to a segment from a core library.-packSegTag :: P.Tagset -> Seg Tag -> X.Seg Word P.Tag-packSegTag tagset = X.mapSeg (P.parseTag tagset) . packSeg -- | 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+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 ] --- | Convert a sentence to a sentence from a core library.-packSentTag :: P.Tagset -> Sent Tag -> X.Sent Word P.Tag-packSentTag = map . packSegTag --- | Convert a sentence to a sentence from a core library.-packSentTagO :: P.Tagset -> SentO Tag -> X.SentO Word P.Tag-packSentTagO tagset s = X.SentO- { segs = packSentTag tagset (segs s)- , orig = orig s }+-- | Convert a segment to a segment from a core library.+packSeg :: P.Tagset -> Seg Tag -> X.Seg Word P.Tag+packSeg tagset = X.mapSeg (P.parseTag tagset) . packSeg_ + -- | Convert a sentence to a sentence from a core library.-packSent :: Ord a => Sent a -> X.Sent Word a-packSent = map packSeg+packSent :: P.Tagset -> Sent Tag -> X.Sent Word P.Tag+packSent = map . packSeg --- | Embed tags in a sentence.-embedSent :: Ord a => Sent a -> [a] -> Sent a-embedSent sent xs = [selectOne x seg | (x, seg) <- zip xs sent] --- | Select one interpretation.-selectOne :: Ord a => a -> Seg a -> Seg a-selectOne x = select (X.mkWMap [(x, 1)])---- | Select interpretations.-select :: Ord a => X.WMap a -> Seg a -> Seg a-select 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 $- [ case M.lookup (tag interp) (X.unWMap wMap) of- Just x -> (interp, asDmb x)- Nothing -> (interp, False)- | interp <- M.keys (interps seg) ]- ++ catMaybes- [ if tag `M.member` wSet seg- then Nothing- else Just (Interp Nothing tag, asDmb x)- | (tag, x) <- M.toList (X.unWMap wMap) ]+-- | Convert a sentence to a sentence from a core library.+packSentO :: P.Tagset -> SentO Tag -> X.SentO Word P.Tag+packSentO tagset s = X.SentO+ { segs = packSent tagset (segs s)+ , orig = orig s }
tools/concraft-pl.hs view
@@ -15,6 +15,7 @@ import GHC.Conc (numCapabilities) import qualified NLP.Concraft.Morphosyntax.Accuracy as Acc+import qualified NLP.Concraft.Guess as Guess import qualified NLP.Concraft.Polish.Maca as Maca import qualified NLP.Concraft.Polish as C@@ -61,7 +62,8 @@ , disk :: Bool , prune :: Maybe Double , outModel :: FilePath- , guessNum :: Int }+ , guessNum :: Int+ , r0 :: Guess.R0T } | Tag { inModel :: FilePath , noAna :: Bool@@ -98,7 +100,8 @@ , 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" }+ , guessNum = 10 &= help "Number of guessed tags for each unknown word"+ , r0 = Guess.OovChosen &= help "R0 construction method" } tagMode :: Concraft@@ -170,7 +173,8 @@ , reana = not noAna , onDisk = disk , guessNum = guessNum- , prune = prune }+ , prune = prune+ , r0 = r0 } exec Tag{..} = do@@ -203,7 +207,7 @@ exec Compare{..} = do tagset <- parseTagset tagsetPath <$> readFile tagsetPath- let convert = map (X.packSegTag tagset) . concat+ let convert = map (X.packSeg tagset) . concat xs <- convert <$> parseFile format refPath ys <- convert <$> parseFile format otherPath let s = Acc.weakLB tagset xs ys@@ -245,7 +249,7 @@ ------------------------------------------ Parsing (format dependent functions)+-- Parsing (format dependent) --------------------------------------- @@ -258,7 +262,7 @@ ------------------------------------------ Showing data+-- Showing (format dependent) ---------------------------------------