diff --git a/concraft.cabal b/concraft.cabal --- a/concraft.cabal +++ b/concraft.cabal @@ -1,5 +1,5 @@ name: concraft -version: 0.12.1 +version: 0.13.0 synopsis: Morphological disambiguation based on constrained CRFs description: A morphological disambiguation library based on diff --git a/src/NLP/Concraft/DAG/Guess.hs b/src/NLP/Concraft/DAG/Guess.hs --- a/src/NLP/Concraft/DAG/Guess.hs +++ b/src/NLP/Concraft/DAG/Guess.hs @@ -62,8 +62,16 @@ -- ^ The tagset considered for the unknown words (TODO: a solution -- parallel and not 100% consistent with what is implemented in the CRF -- library) + -- TODO: with `complexify`, `unkTagSet` is not needed anymore! , simplify :: t -> s -- ^ A tag simplification function + , complexify :: s -> t + -- ^ NEW: instead of an `unkTagSet`, a function which makes a complex tag + -- out of a simple tag. + -- + -- WARNING: we assume, that this function does not conflate simplified + -- tags, i.e., tag to tags of type `s` cannot lead to one and the same + -- complex tag of type `t`. } @@ -87,9 +95,13 @@ -- | Get the disambiguation model, provided the simplification function. -- getGuesser :: (M.Map t T.Tag) -> Get (Guesser t) -getGuesser :: (Binary t, Binary s, Ord s) => (t -> s) -> Get (Guesser t s) -getGuesser smp = - Guesser <$> get <*> get <*> get <*> get <*> pure smp +getGuesser :: + (Binary t, Binary s, Ord s, Ord t) + => (t -> s) + -> (s -> t) + -> Get (Guesser t s) +getGuesser smp cpx = + Guesser <$> get <*> get <*> get <*> get <*> pure smp <*> pure cpx -- -------------------------- @@ -154,12 +166,13 @@ . marginalsCRF cfg gsr $ sent where - tags = X.mkWMap . M.toList . considerZero . choice + tags = X.fromMap . considerZero . choice -- we mix the chosen and the potential interpretations together choice w = M.unionWith (+) (CRF.unProb . CRF.choice $ w) - (M.fromList . map (,0) . interps $ w) - interps = S.toList . CRF.lbs . CRF.word + -- (M.fromList . map (,0) . interps $ w) + (M.fromSet (const 0) . interps $ w) + interps = CRF.lbs . CRF.word -- if empty, we choose the zero probability label. considerZero m | M.null m = M.singleton (zeroProbLab gsr) 0 @@ -201,12 +214,16 @@ -> X.Sent w t -> X.Sent w t inject gsr newSent srcSent = - let doit (target, src) = - let oldTags = if X.oov (X.word src) - then X.mkWMap . map (,0) . S.toList . unkTagSet $ gsr - else X.tags src - newTags = injectWMap gsr target oldTags - in src {X.tags = newTags} + let doit (target, src) + | X.oov (X.word src) = + let newTags = X.fromMap $ M.fromAscList + [ (complexify gsr tag, prob) + | (tag, prob) <- M.toAscList (X.unWMap target) ] + in src {X.tags = newTags} + | otherwise = + let oldTags = X.tags src + newTags = injectWMap gsr target oldTags + in src {X.tags = newTags} in fmap doit (DAG.zipE newSent srcSent) @@ -234,6 +251,9 @@ , maybe 0 id $ M.lookup (simplify gsr tag) (X.unWMap newSpl) ) | (tag, _) <- M.toList (X.unWMap src) ] +-- injectWMap gsr newSpl src = X.fromMap $ M.fromAscList +-- [ (complexify gsr smp, prob) +-- | (smp, prob) <- M.toAscList (X.unWMap newSpl) ] -- -------------------------- @@ -302,8 +322,11 @@ , zeroProbLabel :: t -- | Label simplification function , simplifyLabel :: t -> s - -- | Strip the label from irrelevant information. Used to determine othe set of - -- possible tags for unknown words. + -- | Label complexification function + , complexifyLabel :: s -> t + -- | Strip the label from irrelevant information. Used to determine the + -- set of possible tags for unknown words. + -- TODO: we don't need this with `complexify` anymore!? , stripLabel :: t -> t -- | Guess only visible features , onlyVisible :: Bool @@ -337,7 +360,14 @@ mkR0 featExtract (schemed simplifyLabel schema <$> trainData) (schemed simplifyLabel schema <$> evalData) - return $ Guesser schemaConfT crf (simplifyLabel zeroProbLabel) tagSet simplifyLabel + return $ + Guesser + schemaConfT + crf + (simplifyLabel zeroProbLabel) + tagSet + simplifyLabel + complexifyLabel -- | Schematized dataset. @@ -365,3 +395,8 @@ | edgeID <- DAG.dagEdges dag , let edge = DAG.edgeLabel edgeID dag , tag <- M.keys . X.unWMap . X.tags $ edge ] + + +-- | Compute the default `X.WMap` for unknown tags. +compUnkWMap :: Ord t => S.Set t -> X.WMap t +compUnkWMap = X.mkWMap . map (,0) . S.toList diff --git a/src/NLP/Concraft/DAGSeg.hs b/src/NLP/Concraft/DAGSeg.hs --- a/src/NLP/Concraft/DAGSeg.hs +++ b/src/NLP/Concraft/DAGSeg.hs @@ -108,18 +108,20 @@ :: (Ord t, Binary t) => (P.Tagset -> t -> P.Tag) -- ^ Guesser simplification function + -> (P.Tagset -> P.Tag -> t) + -- ^ Guesser complexification function -> (P.Tagset -> t -> D.Tag) -- ^ Segmentation/disamb simplification function (TODO: two different -- simplification functions?) -> Get (Concraft t) -getModel gsrSmp dmbSmp = do +getModel gsrSmp gsrCpx dmbSmp = do comp <- get when (comp /= modelVersion) $ error $ "Incompatible model version: " ++ comp ++ ", expected: " ++ modelVersion tagset <- get Concraft tagset <$> get - <*> G.getGuesser (gsrSmp tagset) + <*> G.getGuesser (gsrSmp tagset) (gsrCpx tagset) <*> D.getDisamb (dmbSmp tagset) <*> D.getDisamb (dmbSmp tagset) @@ -135,13 +137,15 @@ :: (Ord t, Binary t) => (P.Tagset -> t -> P.Tag) -- ^ Guesser simplification function + -> (P.Tagset -> P.Tag -> t) + -- ^ Guesser complexification function -> (P.Tagset -> t -> D.Tag) -- ^ Disamb simplification function -> FilePath -> IO (Concraft t) -loadModel gsrSmp dmbSmp path = do +loadModel gsrSmp gsrCpx dmbSmp path = do -- x <- Binary.decode . GZip.decompress <$> BL.readFile path - x <- runGet (getModel gsrSmp dmbSmp) . GZip.decompress <$> BL.readFile path + x <- runGet (getModel gsrSmp gsrCpx dmbSmp) . GZip.decompress <$> BL.readFile path x `seq` return x