diff --git a/NLP/Concraft.hs b/NLP/Concraft.hs deleted file mode 100644 --- a/NLP/Concraft.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module NLP.Concraft -( GuessConf (..) -, GuessData (..) -, DisambConf (..) -, DisambWith (..) -, DisambTag -, DisambTrain -, disamb -, disambDoc -, trainOn -) where - --- import Data.Binary (Binary, put, get) --- import qualified Data.Text as T - -import System.IO (hClose) -import Data.Foldable (Foldable) -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.IO as L -import qualified Numeric.SGD as SGD -import qualified System.IO.Temp as Temp - -import NLP.Concraft.Schema -import qualified NLP.Concraft.Morphosyntax as Mx -import qualified NLP.Concraft.Format as F -import qualified NLP.Concraft.Guess as G -import qualified NLP.Concraft.Disamb as D - --- | Guessing configuration. -data GuessConf r = GuessConf - { guessNum :: Int - , guessSchema :: Schema r () } - --- | Guessing configuration and model data. -data GuessData r = GuessData - { guessConf :: GuessConf r - , guesser :: G.Guesser r } - --- | Disambiguation configuration. -data DisambConf r t = DisambConf - { split :: D.Split r t - , disambSchema :: Schema t () } - --- | Disambiguation configuration with... -data DisambWith r t a = DisambWith - { disambConf :: DisambConf r t - , disambWith :: a } - --- | Tagging with disambiguation configuration. -type DisambTag r t = DisambWith r t (D.TagCRF Ob t) - --- | Training disambiguation model configuration. -type DisambTrain r t c = DisambWith r t (D.TrainCRF Ob t c) - --- | Perform disambiguation preceded by context-sensitive guessing. -disamb - :: (Ord r, Ord t) - => GuessData r -- ^ Guessing configuration - -> DisambTag r t -- ^ Disambiguation configuration - -> Mx.Sent r -- ^ Input - -> [r] -- ^ Output -disamb GuessData{..} DisambWith{..} sent - = D.disamb disambSchema split tagCRF - . G.include sent - . G.guess guessNum guessSchema guesser - $ sent - where - GuessConf{..} = guessConf - DisambConf{..} = disambConf - tagCRF = disambWith - --- | Tag the sentence. -disambSent - :: Ord t - => F.Sent s w - -> GuessData F.Tag - -> DisambTag F.Tag t - -> s -> s -disambSent sentH GuessData{..} DisambWith{..} - = D.disambSent sentH disambSchema split tagCRF - . G.guessSent sentH guessNum guessSchema guesser - where - GuessConf{..} = guessConf - DisambConf{..} = disambConf - tagCRF = disambWith - --- | Tag document. -disambDoc - :: (Functor f, Ord t) - => F.Doc f s w -- ^ Document format handler - -> GuessData F.Tag -- ^ Guessing configuration - -> DisambTag F.Tag t -- ^ Disambiguation configuration - -> L.Text -- ^ Input - -> L.Text -- ^ Output -disambDoc F.Doc{..} guessData disambTag = - let onSent = disambSent sentHandler guessData disambTag - in showDoc . fmap onSent . parseDoc - --- | Train guessing and disambiguation models. -trainOn - :: (Functor f, Foldable f, Ord t) - => F.Doc f s w -- ^ Document format handler - -> GuessConf F.Tag -- ^ Guessing configuration - -> SGD.SgdArgs -- ^ SGD params for guesser - -> DisambTrain F.Tag t c -- ^ Disambiguation configuration - -> FilePath -- ^ Training file - -> Maybe FilePath -- ^ Maybe eval file - -> IO (G.Guesser F.Tag, c) -- ^ Resultant models -trainOn format guessConf@GuessConf{..} sgdArgs DisambWith{..} - trainPath evalPath'Maybe = do - putStrLn "\n===== Train guessing model ====\n" - guesser <- G.trainOn format guessSchema sgdArgs - trainPath evalPath'Maybe - let guessData = GuessData guessConf guesser - let withGuesser = guessFile format guessData - withGuesser "train" (Just trainPath) $ \(Just trainPathG) -> - withGuesser "eval" evalPath'Maybe $ \evalPathG'Maybe -> do - putStrLn "\n===== Train disambiguation model ====\n" - let DisambConf{..} = disambConf - let trainCRF = disambWith - disambCRF <- D.trainOn format disambSchema split trainCRF - trainPathG evalPathG'Maybe - return (guesser, disambCRF) - -guessFile - :: Functor f - => F.Doc f s w -- ^ Document format handler - -> GuessData F.Tag -- ^ Guesser - -> String -- ^ Template for temporary file name - -> Maybe FilePath -- ^ File to guess - -> (Maybe FilePath -> IO a) -- ^ Handler - -> IO a -guessFile _ _ _ Nothing handler = handler Nothing -guessFile format GuessData{..} tmpl (Just path) handler = - Temp.withTempFile "." tmpl $ \tmpPath tmpHandle -> do - inp <- L.readFile path - let GuessConf{..} = guessConf - let out = G.guessDoc format guessNum guessSchema guesser inp - hClose tmpHandle - L.writeFile tmpPath out - handler (Just tmpPath) diff --git a/NLP/Concraft/Disamb.hs b/NLP/Concraft/Disamb.hs deleted file mode 100644 --- a/NLP/Concraft/Disamb.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module NLP.Concraft.Disamb -( Split -, TrainCRF -, TagCRF -, disamb -, disambSent -, disambDoc -, trainOn -) where - -import Control.Applicative ((<$>)) -import Data.Maybe (fromJust) -import Data.List (find) -import Data.Foldable (Foldable, foldMap) -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.Vector as V -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.IO as L - -import qualified Control.Monad.Ox as Ox -import qualified Data.CRF.Chain2.Generic.External as CRF - -import NLP.Concraft.Schema -import qualified NLP.Concraft.Morphosyntax as Mx -import qualified NLP.Concraft.Format as F - --- | Schematize the input sentence with according to 'schema' rules. -schematize :: Schema t a -> Mx.Sent t -> CRF.Sent Ob t -schematize schema sent = - [ CRF.mkWord (obs i) (lbs i) - | i <- [0 .. n - 1] ] - where - v = V.fromList sent - n = V.length v - obs = S.fromList . Ox.execOx . schema v - lbs i = Mx.interpsSet w - where w = v V.! i - --- | Split is just a function from an original tag form --- to a complex tag form. -type Split r t = r -> t - --- | Unsplit the complex tag (assuming, that it is one --- of the interpretations of the word). -unSplit :: Eq t => Split r t -> Mx.Word r -> t -> r -unSplit split' word x = fromJust $ find ((==x) . split') (Mx.interps word) - --- | CRF training function. -type TrainCRF o t c - = IO [CRF.SentL o t] -- ^ Training data 'IO' action - -> Maybe (IO [CRF.SentL o t]) -- ^ Maybe evalation data - -> IO c -- ^ Resulting model - --- | CRF tagging function. -type TagCRF o t = CRF.Sent o t -> [t] - --- | Perform context-sensitive disambiguation. -disamb - :: (Ord r, Ord t) - => Schema t a - -> Split r t - -> TagCRF Ob t - -> Mx.Sent r - -> [r] -disamb schema split tag sent - = map (uncurry embed) - . zip sent - . tag - . schematize schema - . Mx.mapSent split - $ sent - where - embed = unSplit split - --- | Tag the sentence. -disambSent - :: Ord t - => F.Sent s w - -> Schema t a - -> Split F.Tag t - -> TagCRF Ob t - -> s -> s -disambSent F.Sent{..} schema split tag sent = - flip mergeSent sent - [ select wMap orig - | (wMap, orig) <- zip - (doDmb sent) - (parseSent sent) ] - where - F.Word{..} = wordHandler - doDmb orig = - let xs = map extract (parseSent orig) - in map (uncurry mkChoice) (zip xs (disamb schema split tag xs)) - mkChoice word x = Mx.mkWMap - [ if x == y - then (x, 1) - else (y, 0) - | y <- Mx.interps word ] - --- | Disambiguate document. -disambDoc - :: (Functor f, Ord t) - => F.Doc f s w -- ^ Document format handler - -> Schema t a -- ^ Observation schema - -> Split F.Tag t -- ^ Tiered tagging - -> TagCRF Ob t -- ^ CRF tagging function - -> L.Text -- ^ Input - -> L.Text -- ^ Output -disambDoc F.Doc{..} schema split tag = - let onSent = disambSent sentHandler schema split tag - in showDoc . fmap onSent . parseDoc - --- | Train disamb model. -trainOn - :: (Foldable f, Ord t) - => F.Doc f s w -- ^ Document format handler - -> Schema t a -- ^ Observation schema - -> Split F.Tag t -- ^ Tiered tagging - -> TrainCRF Ob t c -- ^ CRF training function - -> FilePath -- ^ Training file - -> Maybe FilePath -- ^ Maybe eval file - -> IO c -- ^ Resultant model data -trainOn format schema split train trainPath evalPath'Maybe = do - crf <- train - (schemed format schema split trainPath) - (schemed format schema split <$> evalPath'Maybe) - return crf - --- | Schematized data from the plain file. -schemed - :: (Foldable f, Ord t) - => F.Doc f s w -> Schema t a -> Split F.Tag t - -> FilePath -> IO [CRF.SentL Ob t] -schemed F.Doc{..} schema split path = - foldMap onSent . parseDoc <$> L.readFile path - where - F.Sent{..} = sentHandler - F.Word{..} = wordHandler - onSent sent = - [zip (schematize schema xs) (map mkDist xs)] - where - xs = map (Mx.mapWord split . extract) (parseSent sent) - mkDist = CRF.mkDist . M.toList . Mx.unWMap . Mx.tagWMap diff --git a/NLP/Concraft/Disamb/Positional.hs b/NLP/Concraft/Disamb/Positional.hs deleted file mode 100644 --- a/NLP/Concraft/Disamb/Positional.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} - --- | The module provides functions for splitting positional tags. --- They can be used together with the layered disambiguation model. - -module NLP.Concraft.Disamb.Positional -( Tier (..) -, Part (..) -, select -, split -, tierConfDefault -) where - -import Control.Applicative ((<$>), (<*>)) -import Data.Binary (Binary, put, get) -import Data.Text.Binary () -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Tagset.Positional as TP - --- | A tier description. -data Tier = Tier { - -- | Does it include the part of speech? - withPos :: Bool - -- | Tier grammatical attributes. - , withAtts :: S.Set TP.Attr } - -instance Binary Tier where - put Tier{..} = put withPos >> put withAtts - get = Tier <$> get <*> get - --- | An atomic part of morphosyntactic tag with optional POS. -data Part = Part - { pos :: Maybe TP.POS - , atts :: M.Map TP.Attr T.Text } - deriving (Show, Eq, Ord) - -instance Binary Part where - put Part{..} = put pos >> put atts - get = Part <$> get <*> get - --- | Select tier attributes. -select :: Tier -> TP.Tag -> Part -select Tier{..} tag = Part - { pos = if withPos then Just (TP.pos tag) else Nothing - , atts = M.filterWithKey (\k _ -> k `S.member` withAtts) (TP.atts tag) } - --- | Split the positional tag. -split :: [Tier] -> TP.Tag -> [Part] -split tiers tag = - [ select tier tag - | tier <- tiers ] - --- | Default tiered tagging configuration. -tierConfDefault :: [Tier] -tierConfDefault = - [tier1, tier2] - where - tier1 = Tier True $ S.fromList ["cas", "per"] - tier2 = Tier False $ S.fromList - [ "nmb", "gnd", "deg", "asp" , "ngt", "acm" - , "acn", "ppr", "agg", "vlc", "dot" ] diff --git a/NLP/Concraft/Disamb/Tiered.hs b/NLP/Concraft/Disamb/Tiered.hs deleted file mode 100644 --- a/NLP/Concraft/Disamb/Tiered.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} - -module NLP.Concraft.Disamb.Tiered -( --- * Tiered model - Ob (..) -, Lb (..) -, Feat (..) -, CRF (..) -, train -, tag - --- * Feature selection -, FeatSel -, selectHidden -, selectPresent -) where - -import Control.Applicative ((<$>), (<*>)) -import Control.Comonad.Trans.Store (store) -import Control.Monad (guard) -import Data.Ix (Ix, inRange, range) -import Data.Maybe (catMaybes, fromJust) -import Data.List (zip4, foldl1') -import Data.Lens.Common (Lens(..)) -import Data.Binary (Binary, get, put, Put, Get) -import Data.Vector.Binary () -import qualified Data.Map as M -import qualified Data.Vector as V -import qualified Data.Array.Unboxed as A - -import Data.CRF.Chain2.Generic.Codec - ( Codec(..), mkCodec, encodeDataL - , encodeSent, decodeLabels, unJust ) -import Data.CRF.Chain2.Generic.Model - ( FeatGen(..), Model, FeatSel - , selectHidden, selectPresent - , core, withCore ) -import Data.CRF.Chain2.Generic.Internal (FeatIx(..)) -import qualified Data.CRF.Chain2.Generic.Inference as I -import qualified Data.CRF.Chain2.Generic.Train as Train -import qualified Data.CRF.Chain2.Generic.FeatMap as F -import qualified Control.Monad.Codec as C -import qualified Numeric.SGD as SGD -import qualified NLP.Concraft.Disamb as D - --- | Observation. -newtype Ob = Ob { unOb :: Int } deriving (Show, Eq, Ord, Ix, Binary) - --- | [Sub]label. -newtype Lb = Lb { unLb :: Int } deriving (Show, Eq, Ord, Ix, Binary) - --- | Feature. -data Feat - = TFeat3 - { x1 :: {-# UNPACK #-} !Lb - , x2 :: {-# UNPACK #-} !Lb - , x3 :: {-# UNPACK #-} !Lb - , ln :: {-# UNPACK #-} !Int } - | TFeat2 - { x1 :: {-# UNPACK #-} !Lb - , x2 :: {-# UNPACK #-} !Lb - , ln :: {-# UNPACK #-} !Int } - | TFeat1 - { x1 :: {-# UNPACK #-} !Lb - , ln :: {-# UNPACK #-} !Int } - | OFeat - { ob :: {-# UNPACK #-} !Ob - , x1 :: {-# UNPACK #-} !Lb - , ln :: {-# UNPACK #-} !Int } - deriving (Show, Eq, Ord) - -instance Binary Feat where - put (OFeat o x k) = putI 0 >> put o >> put x >> put k - put (TFeat3 x y z k) = putI 1 >> put x >> put y >> put z >> put k - put (TFeat2 x y k) = putI 2 >> put x >> put y >> put k - put (TFeat1 x k) = putI 3 >> put x >> put k - get = getI >>= \i -> case i of - 0 -> OFeat <$> get <*> get <*> get - 1 -> TFeat3 <$> get <*> get <*> get <*> get - 2 -> TFeat2 <$> get <*> get <*> get - 3 -> TFeat1 <$> get <*> get - _ -> error "get feature: unknown code" - -putI :: Int -> Put -putI = put -{-# INLINE putI #-} - -getI :: Get Int -getI = get -{-# INLINE getI #-} - --- | Feature generation for complex [Lb] label type. -featGen :: FeatGen Ob [Lb] Feat -featGen = FeatGen - { obFeats = obFeats' - , trFeats1 = trFeats1' - , trFeats2 = trFeats2' - , trFeats3 = trFeats3' } - where - obFeats' ob' xs = - [ OFeat ob' x k - | (x, k) <- zip xs [0..] ] - trFeats1' xs = - [ TFeat1 x k - | (x, k) <- zip xs [0..] ] - trFeats2' xs1 xs2 = - [ TFeat2 x1' x2' k - | (x1', x2', k) <- - zip3 xs1 xs2 [0..] ] - trFeats3' xs1 xs2 xs3 = - [ TFeat3 x1' x2' x3' k - | (x1', x2', x3', k) <- - zip4 xs1 xs2 xs3 [0..] ] - --- | Codec internal data. The first component is used to --- encode observations of type a, the second one is used to --- encode labels of type [b]. -type CodecData a b = - ( C.AtomCodec a - , V.Vector (C.AtomCodec (Maybe b)) ) - -obLens :: Lens (a, b) a -obLens = Lens $ \(a, b) -> store (\a' -> (a', b)) a - -lbLens :: Int -> Lens (a, V.Vector b) b -lbLens k = Lens $ \(a, b) -> store - (\x -> (a, b V.// [(k, x)])) - (b V.! k) - --- | Codec dependes on the number of layers. -codec :: (Ord a, Ord b) => Int -> Codec a [b] (CodecData a b) Ob [Lb] -codec n = Codec - { empty = - let x = C.execCodec C.empty (C.encode C.idLens Nothing) - in (C.empty, V.replicate n x) - , encodeObU = fmap Ob . C.encode' obLens - , encodeObN = fmap (fmap Ob) . C.maybeEncode obLens - , encodeLbU = \ xs -> sequence - [ Lb <$> C.encode (lbLens k) (Just x) - | (x, k) <- zip xs [0..] ] - , encodeLbN = \ xs -> - let encode lens x = C.maybeEncode lens (Just x) >>= \mx -> case mx of - Just x' -> return x' - Nothing -> fromJust <$> C.maybeEncode lens Nothing - in sequence - [ Lb <$> encode (lbLens k) x - | (x, k) <- zip xs [0..] ] - , decodeLbC = \ xs -> sequence <$> sequence - [ C.decode (lbLens k) (unLb x) - | (x, k) <- zip xs [0..] ] - , hasLabel = \ cdcData xs -> and - [ M.member - (Just x) - (C.to $ snd cdcData V.! k) - | (x, k) <- zip xs [0..] ] } - --- | Dummy feature index. -dummy :: FeatIx -dummy = FeatIx (-1) -{-# INLINE dummy #-} - --- | Transition map restricted to a particular tagging layer. -type TransMap = A.UArray (Lb, Lb, Lb) FeatIx - --- | CRF feature map. -data FeatMap a = FeatMap - { transMaps :: V.Vector TransMap - , otherMap :: M.Map Feat FeatIx } - -instance Binary (FeatMap Feat) where - put FeatMap{..} = put transMaps >> put otherMap - get = FeatMap <$> get <*> get - -instance F.FeatMap FeatMap Feat where - featIndex (TFeat3 x y z k) (FeatMap v _) = do - m <- v V.!? k - ix <- m !? (x, y, z) - guard (ix /= dummy) - return ix - featIndex x (FeatMap _ m) = M.lookup x m - mkFeatMap xs = FeatMap - ( V.fromList - [ mkArray . catMaybes $ - map (getTFeat3 k) xs - | k <- [0 .. maxLayerNum xs] ] ) - (M.fromList (filter (isOther . fst) xs)) - where - maxLayerNum = maximum . map (ln.fst) - getTFeat3 i (TFeat3 x y z j, v) - | i == j = Just ((x, y, z), v) - | otherwise = Nothing - getTFeat3 _ _ = Nothing - isOther (TFeat3 _ _ _ _) = False - isOther _ = True - mkArray ys = - let p = foldl1' updateMin (map fst ys) - q = foldl1' updateMax (map fst ys) - updateMin (!x, !y, !z) (x', y', z') = - (min x x', min y y', min z z') - updateMax (!x, !y, !z) (x', y', z') = - (max x x', max y y', max z z') - zeroed pq = A.array pq [(k, dummy) | k <- range pq] - in zeroed (p, q) A.// ys - -(!?) :: (Ix i, A.IArray a b) => a i b -> i -> Maybe b -m !? x = if inRange (A.bounds m) x - then Just (m A.! x) - else Nothing -{-# INLINE (!?) #-} - --- | CRF model data. -data CRF a b = CRF - { numOfLayers :: Int - , codecData :: CodecData a b - , model :: Model FeatMap Ob [Lb] Feat } - -instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where - put CRF{..} = put numOfLayers >> put codecData >> put (core model) - get = CRF <$> get <*> get <*> do - _core <- get - return $ withCore _core featGen - --- | Codec specification given the number of layers. -codecSpec - :: (Ord a, Ord b) => Int - -> Train.CodecSpec a [b] (CodecData a b) Ob [Lb] -codecSpec n = Train.CodecSpec - { Train.mkCodec = mkCodec (codec n) - , Train.encode = encodeDataL (codec n) } - --- | Train the CRF using the stochastic gradient descent method. --- Use the provided feature selection function to determine model --- features. -train - :: (Ord o, Ord t) - => Int -- ^ Number of tagging layers - -> FeatSel Ob [Lb] Feat -- ^ Feature selection - -> SGD.SgdArgs -- ^ Args for SGD - -> D.TrainCRF o [t] (CRF o t) -train n featSel sgdArgs trainIO evalIO'Maybe = do - (_codecData, _model) <- Train.train - sgdArgs - (codecSpec n) - featGen - featSel - trainIO - evalIO'Maybe - return $ CRF n _codecData _model - --- | Find the most probable label sequence. -tag :: (Ord o, Ord t) => CRF o t -> D.TagCRF o [t] -tag CRF{..} sent - = onWords . decodeLabels cdc codecData - . I.tag model . encodeSent cdc codecData - $ sent - where - cdc = codec numOfLayers - onWords xs = - [ unJust cdc codecData word x - | (word, x) <- zip sent xs ] diff --git a/NLP/Concraft/Format.hs b/NLP/Concraft/Format.hs deleted file mode 100644 --- a/NLP/Concraft/Format.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | The module provides several abstractions for representing external --- data formats. Concraft will be able to work with any format which --- implements those abstractions. - -module NLP.Concraft.Format -( Tag -, Word (..) -, Sent (..) -, Doc (..) -) where - -import Prelude hiding (words, unwords) -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import qualified NLP.Concraft.Morphosyntax as M - --- | Textual representation of morphposyntactic tag. -type Tag = T.Text - --- | Words handler. -data Word w = Word { - -- | Extract information relevant for tagging. - extract :: w -> M.Word Tag - -- | Select the set of morphosyntactic interpretations. - , select :: M.WMap Tag -> w -> w } - --- | Sentence handler. -data Sent s w = Sent { - -- | Split sentence into a list of words. - parseSent :: s -> [w] - -- | Merge words with a sentence. - , mergeSent :: [w] -> s -> s - -- | Words handler. - , wordHandler :: Word w } - --- | Document format. -data Doc f s w = Doc { - -- | Parse textual interpretations into a functor with - -- sentence elements. - parseDoc :: L.Text -> f s - -- | Show textual reprezentation of a document. - , showDoc :: f s -> L.Text - -- | Sentence handler. - , sentHandler :: Sent s w } diff --git a/NLP/Concraft/Format/Plain.hs b/NLP/Concraft/Format/Plain.hs deleted file mode 100644 --- a/NLP/Concraft/Format/Plain.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | Simple format for morphosyntax representation which --- assumes that all tags have a textual representation --- with no spaces inside and that one of the tags indicates --- unknown words. - -module NLP.Concraft.Format.Plain -( plainFormat -) where - -import Control.Arrow (first) -import Data.Monoid (Monoid, mappend, mconcat) -import Data.Maybe (catMaybes) -import Data.List (groupBy) -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Builder as L - -import qualified NLP.Concraft.Morphosyntax as Mx -import qualified NLP.Concraft.Format as F - --- | No space, space or newline. -data Space - = None - | Space - | NewLine - deriving (Show, Eq, Ord) - --- | A token. -data Token = Token - { orth :: T.Text - , space :: Space - , known :: Bool - -- | 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 Bool } - deriving (Show, Eq, Ord) - -data Interp = Interp - { base :: Maybe T.Text - , tag :: F.Tag } - deriving (Show, Eq, Ord) - -noneBase :: T.Text -noneBase = "None" - --- | Create document handler given value of the /ignore/ tag. -plainFormat :: F.Tag -> F.Doc [] [Token] Token -plainFormat ign = F.Doc (parsePlain ign) (showPlain ign) sentHandler - --- | Sentence handler. -sentHandler :: F.Sent [Token] Token -sentHandler = F.Sent id (\xs _ -> xs) wordHandler - --- | Word handler. -wordHandler :: F.Word Token -wordHandler = F.Word extract select - --- | Extract information relevant for tagging. -extract :: Token -> Mx.Word F.Tag -extract tok = Mx.Word - { Mx.orth = orth tok - , Mx.tagWMap = Mx.mkWMap - [ (tag x, if disamb then 1 else 0) - | (x, disamb) <- M.toList (interps tok) ] - , Mx.oov = not (known tok) } - --- | Select interpretations. -select :: Mx.WMap F.Tag -> Token -> Token -select wMap tok = - tok { 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) (Mx.unWMap wMap) of - Just x -> (interp, asDmb x) - Nothing -> (interp, False) - | interp <- M.keys (interps tok) ] - ++ catMaybes - [ if tag `M.member` wSet tok - then Nothing - else Just (Interp Nothing tag, asDmb x) - | (tag, x) <- M.toList (Mx.unWMap wMap) ] - -parsePlain :: F.Tag -> L.Text -> [[Token]] -parsePlain ign = map (parseSent ign) . init . L.splitOn "\n\n" - -parseSent :: F.Tag -> L.Text -> [Token] -parseSent ign - = map (parseWord ignL) - . groupBy (\_ x -> cond x) - . L.lines - where - cond = ("\t" `L.isPrefixOf`) - ignL = L.fromStrict ign - -parseWord :: L.Text -> [L.Text] -> Token -parseWord ign xs = - (Token _orth _space _known _interps) - where - (_orth, _space) = parseHeader (head xs) - ys = map (parseInterp ign) (tail xs) - _known = not (Nothing `elem` ys) - _interps = M.fromListWith max (catMaybes ys) - -parseInterp :: L.Text -> L.Text -> Maybe (Interp, Bool) -parseInterp ign = - 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) - doIt xs = error $ "parseInterp: " ++ show xs - mkInterp form tag - | formS == noneBase = Interp Nothing tagS - | otherwise = Interp (Just formS) tagS - where - formS = L.toStrict form - tagS = L.toStrict tag - -parseHeader :: L.Text -> (T.Text, Space) -parseHeader xs = - let [_orth, space] = L.splitOn "\t" xs - in (L.toStrict _orth, parseSpace space) - -parseSpace :: L.Text -> Space -parseSpace "none" = None -parseSpace "space" = Space -parseSpace "spaces" = Space -- Is it not a Maca bug? -parseSpace "newline" = NewLine -parseSpace "newlines" = NewLine -- TODO: Remove this temporary fix -parseSpace xs = error ("parseSpace: " ++ L.unpack xs) - --- | Printing. - --- | An infix synonym for 'mappend'. -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -{-# INLINE (<>) #-} - -showPlain :: F.Tag -> [[Token]] -> L.Text -showPlain ign = - L.toLazyText . mconcat . map (\xs -> buildSent ign xs <> "\n") - -buildSent :: F.Tag -> [Token] -> L.Builder -buildSent ign = mconcat . map (buildWord ign) - -buildWord :: F.Tag -> Token -> L.Builder -buildWord ign tok - = L.fromText (orth tok) <> "\t" - <> buildSpace (space tok) <> "\n" - <> buildKnown ign (known tok) - <> buildInterps (M.toList $ interps tok) - -buildInterps :: [(Interp, Bool)] -> L.Builder -buildInterps interps = mconcat - [ "\t" <> buildBase interp <> - "\t" <> buildTag interp <> - if dmb - then "\tdisamb\n" - else "\n" - | (interp, dmb) <- interps ] - where - buildTag = L.fromText . tag - buildBase x = case base x of - Just b -> L.fromText b - Nothing -> L.fromText noneBase - -buildSpace :: Space -> L.Builder -buildSpace None = "none" -buildSpace Space = "space" -buildSpace NewLine = "newline" - -buildKnown :: F.Tag -> Bool -> L.Builder -buildKnown _ True = "" -buildKnown ign False = "\t" <> L.fromText noneBase - <> "\t" <> L.fromText ign <> "\n" diff --git a/NLP/Concraft/Guess.hs b/NLP/Concraft/Guess.hs deleted file mode 100644 --- a/NLP/Concraft/Guess.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module NLP.Concraft.Guess -( Guesser (..) -, guess -, include -, guessSent -, guessDoc -, trainOn -) where - -import Prelude hiding (words) -import Control.Applicative ((<$>)) -import Data.Binary (Binary) -import Data.Foldable (Foldable, foldMap) -import Data.Text.Binary () -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.IO as L -import qualified Data.Vector as V - -import qualified Control.Monad.Ox as Ox -import qualified Data.CRF.Chain1.Constrained as CRF -import qualified Numeric.SGD as SGD - -import NLP.Concraft.Schema -import qualified NLP.Concraft.Morphosyntax as Mx -import qualified NLP.Concraft.Format as F - --- | Schematize the input sentence with according to 'schema' rules. -schematize :: Ord t => Schema t a -> Mx.Sent t -> CRF.Sent Ob t -schematize schema sent = - [ CRF.Word (obs i) (lbs i) - | i <- [0 .. n - 1] ] - where - v = V.fromList sent - n = V.length v - obs = S.fromList . Ox.execOx . schema v - lbs i - | Mx.oov w = S.empty - | otherwise = Mx.interpsSet w - where w = v V.! i - --- | A guesser represented by the conditional random field. -newtype Guesser t = Guesser { crf :: CRF.CRF Ob t } - deriving (Binary) - --- | Determine the 'k' most probable labels for each word in the sentence. -guess :: Ord t => Int -> Schema t a -> Guesser t -> Mx.Sent t -> [[t]] -guess k schema gsr sent = CRF.tagK k (crf gsr) (schematize schema sent) - --- | Include guessing results into weighted tag maps --- assigned to individual words. -includeWMaps :: Ord t => Mx.Sent t -> [[t]] -> [Mx.WMap t] -includeWMaps words guessed = - [ if Mx.oov word - then addInterps (Mx.tagWMap word) xs - else Mx.tagWMap word - | (xs, word) <- zip guessed words ] - where - -- Add new interpretations. - addInterps wm xs = Mx.mkWMap - $ M.toList (Mx.unWMap wm) - ++ zip xs [0, 0 ..] - --- | Include guessing results into the sentence. -include :: Ord t => Mx.Sent t -> [[t]] -> Mx.Sent t -include words guessed = - [ word { Mx.tagWMap = wMap } - | (word, wMap) <- zip words wMaps ] - where - wMaps = includeWMaps words guessed - --- | Tag sentence in external format. Selected interpretations --- (tags correct within the context) will be preserved. -guessSent :: F.Sent s w -> Int -> Schema F.Tag a -> Guesser F.Tag -> s -> s -guessSent F.Sent{..} k schema gsr sent = flip mergeSent sent - [ select wMap word - | (wMap, word) <- zip wMaps (parseSent sent) ] - where - -- Extract word handler. - F.Word{..} = wordHandler - -- Word in internal format. - words = map extract (parseSent sent) - -- Guessed lists of interpretations for individual words. - guessed = guess k schema gsr words - -- Resultant weighted maps. - wMaps = includeWMaps words guessed - --- | Tag file. -guessDoc - :: Functor f - => F.Doc f s w -- ^ Document format handler - -> Int -- ^ Guesser argument - -> Schema F.Tag a -- ^ Observation schema - -> Guesser F.Tag -- ^ Guesser itself - -> L.Text -- ^ Input - -> L.Text -- ^ Output -guessDoc F.Doc{..} k schema gsr - = showDoc - . fmap (guessSent sentHandler k schema gsr) - . parseDoc - --- | Train guesser. -trainOn - :: Foldable f - => F.Doc f s w -- ^ Document format handler - -> Schema F.Tag a -- ^ Observation schema - -> SGD.SgdArgs -- ^ SGD parameters - -> FilePath -- ^ Training file - -> Maybe FilePath -- ^ Maybe eval file - -> IO (Guesser F.Tag) -trainOn format schema sgdArgs trainPath evalPath'Maybe = do - _crf <- CRF.train sgdArgs - (schemed format schema trainPath) - (schemed format schema <$> evalPath'Maybe) - (const CRF.presentFeats) - return $ Guesser _crf - --- | Schematized data from the plain file. -schemed - :: Foldable f => F.Doc f s w -> Schema F.Tag a - -> FilePath -> IO [CRF.SentL Ob F.Tag] -schemed F.Doc{..} schema path = - foldMap onSent . parseDoc <$> L.readFile path - where - F.Sent{..} = sentHandler - F.Word{..} = wordHandler - onSent sent = - let xs = map extract (parseSent sent) - mkProb = CRF.mkProb . M.toList . Mx.unWMap . Mx.tagWMap - in [zip (schematize schema xs) (map mkProb xs)] diff --git a/NLP/Concraft/Morphosyntax.hs b/NLP/Concraft/Morphosyntax.hs deleted file mode 100644 --- a/NLP/Concraft/Morphosyntax.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | Types and functions related to the morphosyntax data layer. - -module NLP.Concraft.Morphosyntax -( --- * Morphosyntax data - Sent -, Word (..) -, mapWord -, mapSent -, interpsSet -, interps --- * Weighted collection -, WMap (unWMap) -, mkWMap -, mapWMap -) where - -import Control.Arrow (first) -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.Text as T - - --- | A sentence of 'Word's. -type Sent t = [Word t] - --- | A word parametrized over a tag type. -data Word t = Word { - -- | Orthographic form. - orth :: T.Text - -- | Set of word interpretations. To each interpretation - -- a "weight of correctness within the context" is assigned. - , tagWMap :: WMap t - -- | Out-of-vocabulary (OOV) word, i.e. word unknown to the - -- morphosyntactic analyser. - , oov :: Bool } - deriving (Show, Eq, Ord) - --- | Map function over word tags. -mapWord :: Ord b => (a -> b) -> Word a -> Word b -mapWord f w = w { tagWMap = mapWMap f (tagWMap w) } - --- | Map function over sentence tags. -mapSent :: Ord b => (a -> b) -> Sent a -> Sent b -mapSent = map . mapWord - --- | Interpretations of the word. -interpsSet :: Word t -> S.Set t -interpsSet = M.keysSet . unWMap . tagWMap - --- | Interpretations of the word. -interps :: Word t -> [t] -interps = S.toList . interpsSet - - --- | A weighted collection of type @a@ elements. -newtype WMap a = WMap { unWMap :: M.Map a Double } - deriving (Show, Eq, Ord) - --- | Make a weighted collection. -mkWMap :: Ord a => [(a, Double)] -> WMap a -mkWMap = WMap . M.fromListWith (+) . filter ((>=0).snd) - --- | Map function over weighted collection elements. -mapWMap :: Ord b => (a -> b) -> WMap a -> WMap b -mapWMap f = mkWMap . map (first f) . M.toList . unWMap diff --git a/NLP/Concraft/Schema.hs b/NLP/Concraft/Schema.hs deleted file mode 100644 --- a/NLP/Concraft/Schema.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module NLP.Concraft.Schema -( Schema -, Ox -, Ob -, guessSchemaDefault -, disambSchemaDefault -) where - -import Control.Applicative ((<$>), (<*>), pure) -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Control.Monad.Ox as Ox -import qualified Control.Monad.Ox.Text as Ox - -import qualified NLP.Concraft.Morphosyntax as Mx - --- | The Ox monad specialized to word token type and text observations. -type Ox t a = Ox.Ox (Mx.Word t) T.Text a - --- | A schema is a block of the Ox computation performed within the --- context of the sentence and the absolute sentence position. -type Schema t a = V.Vector (Mx.Word t) -> Int -> Ox t a - --- | An observation consist of an index (of list type) and an actual --- observation value. -type Ob = ([Int], T.Text) - --- | Default guessing schema. -guessSchemaDefault :: Schema t () -guessSchemaDefault sent = \k -> do - mapM_ (Ox.save . lowPref k) [1, 2] - mapM_ (Ox.save . lowSuff k) [1, 2] - Ox.save (knownAt k) - Ox.save (isBeg k <> pure "-" <> shapeP k) - where - at = Ox.atWith sent - lowOrth i = T.toLower <$> Mx.orth `at` i - lowPref i j = Ox.prefix j =<< lowOrth i - lowSuff i j = Ox.suffix j =<< lowOrth i - shape i = Ox.shape <$> Mx.orth `at` i - shapeP i = Ox.pack <$> shape i - knownAt i = boolF <$> (not . Mx.oov) `at` i - isBeg i = (Just . boolF) (i == 0) - boolF True = "T" - boolF False = "F" - x <> y = T.append <$> x <*> y - --- | Default disambiguation schema. -disambSchemaDefault :: Schema t () -disambSchemaDefault sent = \k -> do - mapM_ (Ox.save . lowOrth) [k - 1, k, k + 1] - _ <- Ox.whenJT (Mx.oov `at` k) $ do - mapM_ (Ox.save . lowPref k) [1, 2, 3] - mapM_ (Ox.save . lowSuff k) [1, 2, 3] - Ox.save (isBeg k <> pure "-" <> shapeP k) - return () - where - at = Ox.atWith sent - lowOrth i = T.toLower <$> Mx.orth `at` i - lowPref i j = Ox.prefix j =<< lowOrth i - lowSuff i j = Ox.suffix j =<< lowOrth i - shape i = Ox.shape <$> Mx.orth `at` i - shapeP i = Ox.pack <$> shape i - isBeg i = (Just . boolF) (i == 0) - boolF True = "T" - boolF False = "F" - x <> y = T.append <$> x <*> y diff --git a/concraft.cabal b/concraft.cabal --- a/concraft.cabal +++ b/concraft.cabal @@ -1,5 +1,5 @@ name: concraft -version: 0.3.2 +version: 0.4.0 synopsis: Morphosyntactic tagging tool based on constrained CRFs description: A morphosyntactic tagging tool based on constrained conditional @@ -16,6 +16,8 @@ build-type: Simple library + hs-source-dirs: src + build-depends: base >= 4 && < 5 , array @@ -37,13 +39,15 @@ exposed-modules: NLP.Concraft + , NLP.Concraft.Guess + , NLP.Concraft.Disamb , NLP.Concraft.Morphosyntax , NLP.Concraft.Format , NLP.Concraft.Format.Plain , NLP.Concraft.Schema - , NLP.Concraft.Guess - , NLP.Concraft.Disamb - , NLP.Concraft.Disamb.Tiered + + other-modules: + NLP.Concraft.Disamb.Tiered , NLP.Concraft.Disamb.Positional ghc-options: -Wall -O2 @@ -52,23 +56,9 @@ type: git location: https://github.com/kawu/concraft.git --- executable concraft-guess --- build-depends: --- cmdargs --- hs-source-dirs: ., tools --- main-is: concraft-guess.hs --- ghc-options: -Wall -O2 -threaded -rtsopts --- --- executable concraft-disamb --- build-depends: --- cmdargs --- hs-source-dirs: ., tools --- main-is: concraft-disamb.hs --- ghc-options: -Wall -O2 -threaded -rtsopts - executable concraft build-depends: cmdargs - hs-source-dirs: ., tools + hs-source-dirs: src, tools main-is: concraft.hs ghc-options: -Wall -O2 -threaded -rtsopts diff --git a/src/NLP/Concraft.hs b/src/NLP/Concraft.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE RecordWildCards #-} + +module NLP.Concraft +( +-- * Types + Concraft (..) + +-- * Tagging +, tag +, tagSent +, tagDoc + +-- * Training +, train +) where + +import System.IO (hClose) +import Control.Applicative ((<$>), (<*>)) +import Data.Foldable (Foldable) +import Data.Binary (Binary, put, get) +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.IO as L +import qualified System.IO.Temp as Temp + +import qualified NLP.Concraft.Morphosyntax as Mx +import qualified NLP.Concraft.Format as F +import qualified NLP.Concraft.Guess as G +import qualified NLP.Concraft.Disamb as D + +-- | Concraft data. +data Concraft = Concraft + { guessNum :: Int + , guesser :: G.Guesser F.Tag + , disamb :: D.Disamb } + +instance Binary Concraft where + put Concraft{..} = do + put guessNum + put guesser + put disamb + get = Concraft <$> get <*> get <*> get + +-- | Perform disambiguation preceded by context-sensitive guessing. +tag :: Concraft -> Mx.Sent F.Tag -> [F.Tag] +tag Concraft{..} sent + = D.disamb disamb + . G.include sent + . G.guess guessNum guesser + $ sent + +-- | Tag the sentence. +tagSent :: F.Sent s w -> Concraft -> s -> s +tagSent sentH Concraft{..} + = D.disambSent sentH disamb + . G.guessSent sentH guessNum guesser + +-- | Tag document. +tagDoc :: Functor f => F.Doc f s w -> Concraft -> L.Text -> L.Text +tagDoc F.Doc{..} concraft = + let onSent = tagSent sentHandler concraft + in showDoc . fmap onSent . parseDoc + +-- | Train guessing and disambiguation models. +train + :: (Functor f, Foldable f) + => F.Doc f s w -- ^ Document format handler + -> Int -- ^ Numer of guessed tags for each word + -> G.TrainConf -- ^ Guessing model training configuration + -> D.TrainConf -- ^ Disambiguation model training configuration + -> FilePath -- ^ Training file + -> Maybe FilePath -- ^ Maybe eval file + -> IO Concraft -- ^ Resultant models +train format guessNum guessConf disambConf trainPath evalPath'Maybe = do + putStrLn "\n===== Train guessing model ====\n" + guesser <- G.train format guessConf trainPath evalPath'Maybe + let withGuesser = guessFile format guessNum guesser + withGuesser "train" (Just trainPath) $ \(Just trainPathG) -> + withGuesser "eval" evalPath'Maybe $ \evalPathG'Maybe -> do + putStrLn "\n===== Train disambiguation model ====\n" + disamb <- D.train format disambConf trainPathG evalPathG'Maybe + return $ Concraft guessNum guesser disamb + +guessFile + :: Functor f + => F.Doc f s w -- ^ Document format handler + -> Int -- ^ Numer of guessed tags for each word + -> G.Guesser F.Tag -- ^ Guesser + -> String -- ^ Template for temporary file name + -> Maybe FilePath -- ^ File to guess + -> (Maybe FilePath -> IO a) -- ^ Handler + -> IO a +guessFile _ _ _ _ Nothing handler = handler Nothing +guessFile format guessNum gsr tmpl (Just path) handler = + Temp.withTempFile "." tmpl $ \tmpPath tmpHandle -> do + inp <- L.readFile path + let out = G.guessDoc format guessNum gsr inp + hClose tmpHandle + L.writeFile tmpPath out + handler (Just tmpPath) diff --git a/src/NLP/Concraft/Disamb.hs b/src/NLP/Concraft/Disamb.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Disamb.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE RecordWildCards #-} + +module NLP.Concraft.Disamb +( +-- * Model + Disamb (..) +, Tier.CRF () + +-- * Tiers +, P.Tier (..) +, P.Atom (..) +, P.tiersDefault + +-- * Disambiguation +, disamb +, disambSent +, disambDoc + +-- * Training +, TrainConf (..) +, train +) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Maybe (fromJust) +import Data.List (find) +import Data.Foldable (Foldable, foldMap) +import Data.Binary (Binary, put, get) +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Vector as V +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.IO as L + +import qualified Control.Monad.Ox as Ox +import qualified Data.CRF.Chain2.Generic.External as CRF + +import NLP.Concraft.Schema hiding (schematize) +import qualified NLP.Concraft.Morphosyntax as Mx +import qualified NLP.Concraft.Format as F + +import qualified NLP.Concraft.Disamb.Tiered as Tier +import qualified NLP.Concraft.Disamb.Positional as P +import qualified Data.Tagset.Positional as TP +import qualified Numeric.SGD as SGD + +-- | Schematize the input sentence with according to 'schema' rules. +schematize :: Schema t a -> Mx.Sent t -> CRF.Sent Ob t +schematize schema sent = + [ CRF.mkWord (obs i) (lbs i) + | i <- [0 .. n - 1] ] + where + v = V.fromList sent + n = V.length v + obs = S.fromList . Ox.execOx . schema v + lbs i = Mx.interpsSet w + where w = v V.! i + +-- | A disambiguation model. +data Disamb = Disamb + { tagset :: TP.Tagset + , tiers :: [P.Tier] + , schemaConf :: SchemaConf + , crf :: Tier.CRF Ob P.Atom } + +instance Binary Disamb where + put Disamb{..} = put tagset >> put tiers >> put schemaConf >> put crf + get = Disamb <$> get <*> get <*> get <*> get + +-- | Unsplit the complex tag (assuming, that it is one +-- of the interpretations of the word). +unSplit :: Eq t => (r -> t) -> Mx.Word r -> t -> r +unSplit split' word x = fromJust $ find ((==x) . split') (Mx.interps word) + +-- -- | CRF training function. +-- type TrainCRF o t c +-- = IO [CRF.SentL o t] -- ^ Training data 'IO' action +-- -> Maybe (IO [CRF.SentL o t]) -- ^ Maybe evalation data +-- -> IO c -- ^ Resulting model +-- +-- -- | CRF tagging function. +-- type TagCRF o t = CRF.Sent o t -> [t] + +-- | Perform context-sensitive disambiguation. +disamb :: Disamb -> Mx.Sent F.Tag -> [F.Tag] +disamb Disamb{..} sent + = map (uncurry embed) + . zip sent + . Tier.tag crf + . schematize schema + . Mx.mapSent split + $ sent + where + schema = fromConf schemaConf + split = P.split tiers . TP.parseTag tagset + embed = unSplit split + +-- | Tag the sentence. +disambSent :: F.Sent s w -> Disamb -> s -> s +disambSent F.Sent{..} dmb sent = + flip mergeSent sent + [ select wMap orig + | (wMap, orig) <- zip + (doDmb sent) + (parseSent sent) ] + where + F.Word{..} = wordHandler + doDmb orig = + let xs = map extract (parseSent orig) + in map (uncurry mkChoice) (zip xs (disamb dmb xs)) + mkChoice word x = Mx.mkWMap + [ if x == y + then (x, 1) + else (y, 0) + | y <- Mx.interps word ] + +-- | Disambiguate document. +disambDoc :: Functor f => F.Doc f s w -> Disamb -> L.Text -> L.Text +disambDoc F.Doc{..} dmb = + let onSent = disambSent sentHandler dmb + in showDoc . fmap onSent . parseDoc + +-- | Training configuration. +data TrainConf = TrainConf + { tagsetT :: TP.Tagset + , tiersT :: [P.Tier] + , schemaConfT :: SchemaConf + , sgdArgsT :: SGD.SgdArgs } + +-- | Train disamb model. +train + :: Foldable f + => F.Doc f s w -- ^ Document format handler + -> TrainConf -- ^ Training configuration + -> FilePath -- ^ Training file + -> Maybe FilePath -- ^ Maybe eval file + -> IO Disamb -- ^ Resultant model +train format TrainConf{..} trainPath evalPath'Maybe = do + crf <- Tier.train + (length tiersT) + sgdArgsT + (schemed format schema split trainPath) + (schemed format schema split <$> evalPath'Maybe) + return $ Disamb tagsetT tiersT schemaConfT crf + where + schema = fromConf schemaConfT + split = P.split tiersT . TP.parseTag tagsetT + +-- | Schematized data from the plain file. +schemed + :: (Foldable f, Ord t) + => F.Doc f s w -> Schema t a -> (F.Tag -> t) + -> FilePath -> IO [CRF.SentL Ob t] +schemed F.Doc{..} schema split path = + foldMap onSent . parseDoc <$> L.readFile path + where + F.Sent{..} = sentHandler + F.Word{..} = wordHandler + onSent sent = + [zip (schematize schema xs) (map mkDist xs)] + where + xs = map (Mx.mapWord split . extract) (parseSent sent) + mkDist = CRF.mkDist . M.toList . Mx.unWMap . Mx.tagWMap diff --git a/src/NLP/Concraft/Disamb/Positional.hs b/src/NLP/Concraft/Disamb/Positional.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Disamb/Positional.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The module provides functions for splitting positional tags. +-- They can be used together with the layered disambiguation model. + +module NLP.Concraft.Disamb.Positional +( Tier (..) +, Atom (..) +, select +, split +, tiersDefault +) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Binary (Binary, put, get) +import Data.Text.Binary () +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Tagset.Positional as TP + +-- | A tier description. +data Tier = Tier { + -- | Does it include the part of speech? + withPos :: Bool + -- | Tier grammatical attributes. + , withAtts :: S.Set TP.Attr } + +instance Binary Tier where + put Tier{..} = put withPos >> put withAtts + get = Tier <$> get <*> get + +-- | An atomic part of morphosyntactic tag with optional POS. +data Atom = Atom + { pos :: Maybe TP.POS + , atts :: M.Map TP.Attr T.Text } + deriving (Show, Eq, Ord) + +instance Binary Atom where + put Atom{..} = put pos >> put atts + get = Atom <$> get <*> get + +-- | Select tier attributes. +select :: Tier -> TP.Tag -> Atom +select Tier{..} tag = Atom + { pos = if withPos then Just (TP.pos tag) else Nothing + , atts = M.filterWithKey (\k _ -> k `S.member` withAtts) (TP.atts tag) } + +-- | Split the positional tag. +split :: [Tier] -> TP.Tag -> [Atom] +split tiers tag = + [ select tier tag + | tier <- tiers ] + +-- | Default tiered tagging configuration. +tiersDefault :: [Tier] +tiersDefault = + [tier1, tier2] + where + tier1 = Tier True $ S.fromList ["cas", "per"] + tier2 = Tier False $ S.fromList + [ "nmb", "gnd", "deg", "asp" , "ngt", "acm" + , "acn", "ppr", "agg", "vlc", "dot" ] diff --git a/src/NLP/Concraft/Disamb/Tiered.hs b/src/NLP/Concraft/Disamb/Tiered.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Disamb/Tiered.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} + +module NLP.Concraft.Disamb.Tiered +( Ob (..) +, Lb (..) +, Feat (..) +, CRF (..) +, train +, tag +) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Comonad.Trans.Store (store) +import Control.Monad (guard) +import Data.Ix (Ix, inRange, range) +import Data.Maybe (catMaybes, fromJust) +import Data.List (zip4, foldl1') +import Data.Lens.Common (Lens(..)) +import Data.Binary (Binary, get, put, Put, Get) +import Data.Vector.Binary () +import qualified Data.Map as M +import qualified Data.Vector as V +import qualified Data.Array.Unboxed as A + +import Data.CRF.Chain2.Generic.Codec + ( Codec(..), mkCodec, encodeDataL + , encodeSent, decodeLabels, unJust ) +import Data.CRF.Chain2.Generic.Model + ( FeatGen(..), Model, selectHidden + , core, withCore ) +import Data.CRF.Chain2.Generic.Internal (FeatIx(..)) +import qualified Data.CRF.Chain2.Generic.Inference as I +import qualified Data.CRF.Chain2.Generic.External as E +import qualified Data.CRF.Chain2.Generic.Train as Train +import qualified Data.CRF.Chain2.Generic.FeatMap as F +import qualified Control.Monad.Codec as C +import qualified Numeric.SGD as SGD + +-- | Observation. +newtype Ob = Ob { unOb :: Int } deriving (Show, Eq, Ord, Ix, Binary) + +-- | Sublabel. +newtype Lb = Lb { unLb :: Int } deriving (Show, Eq, Ord, Ix, Binary) + +-- | Feature. +data Feat + = TFeat3 + { x1 :: {-# UNPACK #-} !Lb + , x2 :: {-# UNPACK #-} !Lb + , x3 :: {-# UNPACK #-} !Lb + , ln :: {-# UNPACK #-} !Int } + | TFeat2 + { x1 :: {-# UNPACK #-} !Lb + , x2 :: {-# UNPACK #-} !Lb + , ln :: {-# UNPACK #-} !Int } + | TFeat1 + { x1 :: {-# UNPACK #-} !Lb + , ln :: {-# UNPACK #-} !Int } + | OFeat + { ob :: {-# UNPACK #-} !Ob + , x1 :: {-# UNPACK #-} !Lb + , ln :: {-# UNPACK #-} !Int } + deriving (Show, Eq, Ord) + +instance Binary Feat where + put (OFeat o x k) = putI 0 >> put o >> put x >> put k + put (TFeat3 x y z k) = putI 1 >> put x >> put y >> put z >> put k + put (TFeat2 x y k) = putI 2 >> put x >> put y >> put k + put (TFeat1 x k) = putI 3 >> put x >> put k + get = getI >>= \i -> case i of + 0 -> OFeat <$> get <*> get <*> get + 1 -> TFeat3 <$> get <*> get <*> get <*> get + 2 -> TFeat2 <$> get <*> get <*> get + 3 -> TFeat1 <$> get <*> get + _ -> error "get feature: unknown code" + +putI :: Int -> Put +putI = put +{-# INLINE putI #-} + +getI :: Get Int +getI = get +{-# INLINE getI #-} + +-- | Feature generation for complex [Lb] label type. +featGen :: FeatGen Ob [Lb] Feat +featGen = FeatGen + { obFeats = obFeats' + , trFeats1 = trFeats1' + , trFeats2 = trFeats2' + , trFeats3 = trFeats3' } + where + obFeats' ob' xs = + [ OFeat ob' x k + | (x, k) <- zip xs [0..] ] + trFeats1' xs = + [ TFeat1 x k + | (x, k) <- zip xs [0..] ] + trFeats2' xs1 xs2 = + [ TFeat2 x1' x2' k + | (x1', x2', k) <- + zip3 xs1 xs2 [0..] ] + trFeats3' xs1 xs2 xs3 = + [ TFeat3 x1' x2' x3' k + | (x1', x2', x3', k) <- + zip4 xs1 xs2 xs3 [0..] ] + +-- | Codec internal data. The first component is used to +-- encode observations of type a, the second one is used to +-- encode labels of type [b]. +type CodecData a b = + ( C.AtomCodec a + , V.Vector (C.AtomCodec (Maybe b)) ) + +obLens :: Lens (a, b) a +obLens = Lens $ \(a, b) -> store (\a' -> (a', b)) a + +lbLens :: Int -> Lens (a, V.Vector b) b +lbLens k = Lens $ \(a, b) -> store + (\x -> (a, b V.// [(k, x)])) + (b V.! k) + +-- | Codec dependes on the number of layers. +codec :: (Ord a, Ord b) => Int -> Codec a [b] (CodecData a b) Ob [Lb] +codec n = Codec + { empty = + let x = C.execCodec C.empty (C.encode C.idLens Nothing) + in (C.empty, V.replicate n x) + , encodeObU = fmap Ob . C.encode' obLens + , encodeObN = fmap (fmap Ob) . C.maybeEncode obLens + , encodeLbU = \ xs -> sequence + [ Lb <$> C.encode (lbLens k) (Just x) + | (x, k) <- zip xs [0..] ] + , encodeLbN = \ xs -> + let encode lens x = C.maybeEncode lens (Just x) >>= \mx -> case mx of + Just x' -> return x' + Nothing -> fromJust <$> C.maybeEncode lens Nothing + in sequence + [ Lb <$> encode (lbLens k) x + | (x, k) <- zip xs [0..] ] + , decodeLbC = \ xs -> sequence <$> sequence + [ C.decode (lbLens k) (unLb x) + | (x, k) <- zip xs [0..] ] + , hasLabel = \ cdcData xs -> and + [ M.member + (Just x) + (C.to $ snd cdcData V.! k) + | (x, k) <- zip xs [0..] ] } + +-- | Dummy feature index. +dummy :: FeatIx +dummy = FeatIx (-1) +{-# INLINE dummy #-} + +-- | Transition map restricted to a particular tagging layer. +type TransMap = A.UArray (Lb, Lb, Lb) FeatIx + +-- | CRF feature map. +data FeatMap a = FeatMap + { transMaps :: V.Vector TransMap + , otherMap :: M.Map Feat FeatIx } + +instance Binary (FeatMap Feat) where + put FeatMap{..} = put transMaps >> put otherMap + get = FeatMap <$> get <*> get + +instance F.FeatMap FeatMap Feat where + featIndex (TFeat3 x y z k) (FeatMap v _) = do + m <- v V.!? k + ix <- m !? (x, y, z) + guard (ix /= dummy) + return ix + featIndex x (FeatMap _ m) = M.lookup x m + mkFeatMap xs = FeatMap + ( V.fromList + [ mkArray . catMaybes $ + map (getTFeat3 k) xs + | k <- [0 .. maxLayerNum xs] ] ) + (M.fromList (filter (isOther . fst) xs)) + where + maxLayerNum = maximum . map (ln.fst) + getTFeat3 i (TFeat3 x y z j, v) + | i == j = Just ((x, y, z), v) + | otherwise = Nothing + getTFeat3 _ _ = Nothing + isOther (TFeat3 _ _ _ _) = False + isOther _ = True + mkArray ys = + let p = foldl1' updateMin (map fst ys) + q = foldl1' updateMax (map fst ys) + updateMin (!x, !y, !z) (x', y', z') = + (min x x', min y y', min z z') + updateMax (!x, !y, !z) (x', y', z') = + (max x x', max y y', max z z') + zeroed pq = A.array pq [(k, dummy) | k <- range pq] + in zeroed (p, q) A.// ys + +(!?) :: (Ix i, A.IArray a b) => a i b -> i -> Maybe b +m !? x = if inRange (A.bounds m) x + then Just (m A.! x) + else Nothing +{-# INLINE (!?) #-} + +-- | CRF model data. +data CRF a b = CRF + { numOfLayers :: Int + , codecData :: CodecData a b + , model :: Model FeatMap Ob [Lb] Feat } + +instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where + put CRF{..} = put numOfLayers >> put codecData >> put (core model) + get = CRF <$> get <*> get <*> do + _core <- get + return $ withCore _core featGen + +-- | Codec specification given the number of layers. +codecSpec + :: (Ord a, Ord b) => Int + -> Train.CodecSpec a [b] (CodecData a b) Ob [Lb] +codecSpec n = Train.CodecSpec + { Train.mkCodec = mkCodec (codec n) + , Train.encode = encodeDataL (codec n) } + +-- | Train the CRF using the stochastic gradient descent method. +-- Use the provided feature selection function to determine model +-- features. +train + :: (Ord o, Ord t) + => Int -- ^ Number of tagging layers + -> SGD.SgdArgs -- ^ Args for SGD + -> IO [E.SentL o [t]] -- ^ Training data 'IO' action + -> Maybe (IO [E.SentL o [t]]) -- ^ Maybe evalation data + -> IO (CRF o t) -- ^ Resulting model +train n sgdArgs trainIO evalIO'Maybe = do + (_codecData, _model) <- Train.train + sgdArgs + (codecSpec n) + featGen + selectHidden + trainIO + evalIO'Maybe + return $ CRF n _codecData _model + +-- | Find the most probable label sequence. +tag :: (Ord o, Ord t) => CRF o t -> E.Sent o [t] -> [[t]] +tag CRF{..} sent + = onWords . decodeLabels cdc codecData + . I.tag model . encodeSent cdc codecData + $ sent + where + cdc = codec numOfLayers + onWords xs = + [ unJust cdc codecData word x + | (word, x) <- zip sent xs ] diff --git a/src/NLP/Concraft/Format.hs b/src/NLP/Concraft/Format.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Format.hs @@ -0,0 +1,44 @@ +-- | The module provides several abstractions for representing external +-- data formats. Concraft will be able to work with any format which +-- implements those abstractions. + +module NLP.Concraft.Format +( Tag +, Word (..) +, Sent (..) +, Doc (..) +) where + +import Prelude hiding (words, unwords) +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified NLP.Concraft.Morphosyntax as M + +-- | Textual representation of morphposyntactic tag. +type Tag = T.Text + +-- | Word handler. +data Word w = Word { + -- | Extract information relevant for tagging. + extract :: w -> M.Word Tag + -- | Select the set of morphosyntactic interpretations. + , select :: M.WMap Tag -> w -> w } + +-- | Sentence handler. +data Sent s w = Sent { + -- | Split sentence into a list of words. + parseSent :: s -> [w] + -- | Merge words with a sentence. + , mergeSent :: [w] -> s -> s + -- | Words handler. + , wordHandler :: Word w } + +-- | Document format. +data Doc f s w = Doc { + -- | Parse textual interpretations into a functor with + -- sentence elements. + parseDoc :: L.Text -> f s + -- | Show textual reprezentation of a document. + , showDoc :: f s -> L.Text + -- | Sentence handler. + , sentHandler :: Sent s w } diff --git a/src/NLP/Concraft/Format/Plain.hs b/src/NLP/Concraft/Format/Plain.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Format/Plain.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Simple format for morphosyntax representation which +-- assumes that all tags have a textual representation +-- with no spaces inside and that one of the tags indicates +-- unknown words. + +module NLP.Concraft.Format.Plain +( +-- * Types + Token (..) +, Interp (..) +, Space (..) +-- * Format handler +, plainFormat +-- * Parsing +, parsePlain +, parseSent +-- * Printing +, showPlain +, showSent +) where + +import Control.Arrow (first) +import Data.Monoid (Monoid, mappend, mconcat) +import Data.Maybe (catMaybes) +import Data.List (groupBy) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as L + +import qualified NLP.Concraft.Morphosyntax as Mx +import qualified NLP.Concraft.Format as F + +-- | No space, space or newline. +data Space + = None + | Space + | NewLine + deriving (Show, Eq, Ord) + +-- | A token. +data Token = Token + { orth :: T.Text + , space :: Space + , known :: Bool + -- | 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 Bool } + deriving (Show, Eq, Ord) + +data Interp = Interp + { base :: Maybe T.Text + , tag :: F.Tag } + deriving (Show, Eq, Ord) + +noneBase :: T.Text +noneBase = "None" + +-- | Create document handler given value of the /ignore/ tag. +plainFormat :: F.Tag -> F.Doc [] [Token] Token +plainFormat ign = F.Doc (parsePlain ign) (showPlain ign) sentHandler + +-- | Sentence handler. +sentHandler :: F.Sent [Token] Token +sentHandler = F.Sent id (\xs _ -> xs) wordHandler + +-- | Word handler. +wordHandler :: F.Word Token +wordHandler = F.Word extract select + +-- | Extract information relevant for tagging. +extract :: Token -> Mx.Word F.Tag +extract tok = Mx.Word + { Mx.orth = orth tok + , Mx.tagWMap = Mx.mkWMap + [ (tag x, if disamb then 1 else 0) + | (x, disamb) <- M.toList (interps tok) ] + , Mx.oov = not (known tok) } + +-- | Select interpretations. +select :: Mx.WMap F.Tag -> Token -> Token +select wMap tok = + tok { 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) (Mx.unWMap wMap) of + Just x -> (interp, asDmb x) + Nothing -> (interp, False) + | interp <- M.keys (interps tok) ] + ++ catMaybes + [ if tag `M.member` wSet tok + then Nothing + else Just (Interp Nothing tag, asDmb x) + | (tag, x) <- M.toList (Mx.unWMap wMap) ] + +-- | Parse the text in the plain format given the /oov/ tag. +parsePlain :: F.Tag -> L.Text -> [[Token]] +parsePlain ign = map (parseSent ign) . init . L.splitOn "\n\n" + +-- | Parse the sentence in the plain format given the /oov/ tag. +parseSent :: F.Tag -> L.Text -> [Token] +parseSent ign + = map (parseWord ignL) + . groupBy (\_ x -> cond x) + . L.lines + where + cond = ("\t" `L.isPrefixOf`) + ignL = L.fromStrict ign + +parseWord :: L.Text -> [L.Text] -> Token +parseWord ign xs = + (Token _orth _space _known _interps) + where + (_orth, _space) = parseHeader (head xs) + ys = map (parseInterp ign) (tail xs) + _known = not (Nothing `elem` ys) + _interps = M.fromListWith max (catMaybes ys) + +parseInterp :: L.Text -> L.Text -> Maybe (Interp, Bool) +parseInterp ign = + 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) + doIt xs = error $ "parseInterp: " ++ show xs + mkInterp form tag + | formS == noneBase = Interp Nothing tagS + | otherwise = Interp (Just formS) tagS + where + formS = L.toStrict form + tagS = L.toStrict tag + +parseHeader :: L.Text -> (T.Text, Space) +parseHeader xs = + let [_orth, space] = L.splitOn "\t" xs + in (L.toStrict _orth, parseSpace space) + +parseSpace :: L.Text -> Space +parseSpace "none" = None +parseSpace "space" = Space +parseSpace "spaces" = Space -- Is it not a Maca bug? +parseSpace "newline" = NewLine +parseSpace "newlines" = NewLine -- TODO: Remove this temporary fix +parseSpace xs = error ("parseSpace: " ++ L.unpack xs) + +----------- +-- Printing +----------- + +-- | An infix synonym for 'mappend'. +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +{-# INLINE (<>) #-} + +-- | Show the plain data. +showPlain :: F.Tag -> [[Token]] -> L.Text +showPlain ign = + L.toLazyText . mconcat . map (\xs -> buildSent ign xs <> "\n") + +-- | Show the sentence. +showSent :: F.Tag -> [Token] -> L.Text +showSent ign xs = L.toLazyText $ buildSent ign xs + +buildSent :: F.Tag -> [Token] -> L.Builder +buildSent ign = mconcat . map (buildWord ign) + +buildWord :: F.Tag -> Token -> L.Builder +buildWord ign tok + = L.fromText (orth tok) <> "\t" + <> buildSpace (space tok) <> "\n" + <> buildKnown ign (known tok) + <> buildInterps (M.toList $ interps tok) + +buildInterps :: [(Interp, Bool)] -> L.Builder +buildInterps interps = mconcat + [ "\t" <> buildBase interp <> + "\t" <> buildTag interp <> + if dmb + then "\tdisamb\n" + else "\n" + | (interp, dmb) <- interps ] + where + buildTag = L.fromText . tag + buildBase x = case base x of + Just b -> L.fromText b + Nothing -> L.fromText noneBase + +buildSpace :: Space -> L.Builder +buildSpace None = "none" +buildSpace Space = "space" +buildSpace NewLine = "newline" + +buildKnown :: F.Tag -> Bool -> L.Builder +buildKnown _ True = "" +buildKnown ign False = "\t" <> L.fromText noneBase + <> "\t" <> L.fromText ign <> "\n" diff --git a/src/NLP/Concraft/Guess.hs b/src/NLP/Concraft/Guess.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Guess.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE RecordWildCards #-} + +module NLP.Concraft.Guess +( +-- * Types + Guesser (..) + +-- * Guessing +, guess +, guessSent +, guessDoc +, include + +-- * Training +, TrainConf (..) +, train +) where + +import Prelude hiding (words) +import Control.Applicative ((<$>), (<*>)) +import Data.Binary (Binary, put, get) +import Data.Foldable (Foldable, foldMap) +import Data.Text.Binary () +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.IO as L +import qualified Data.Vector as V + +import qualified Control.Monad.Ox as Ox +import qualified Data.CRF.Chain1.Constrained as CRF +import qualified Numeric.SGD as SGD + +import NLP.Concraft.Schema hiding (schematize) +import qualified NLP.Concraft.Morphosyntax as Mx +import qualified NLP.Concraft.Format as F + +-- | A guessing model. +data Guesser t = Guesser + { schemaConf :: SchemaConf + , crf :: CRF.CRF Ob t } + +instance (Ord t, Binary t) => Binary (Guesser t) where + put Guesser{..} = put schemaConf >> put crf + get = Guesser <$> get <*> get + +-- | Schematize the input sentence with according to 'schema' rules. +schematize :: Ord t => Schema t a -> Mx.Sent t -> CRF.Sent Ob t +schematize schema sent = + [ CRF.Word (obs i) (lbs i) + | i <- [0 .. n - 1] ] + where + v = V.fromList sent + n = V.length v + obs = S.fromList . Ox.execOx . schema v + lbs i + | Mx.oov w = S.empty + | otherwise = Mx.interpsSet w + where w = v V.! i + +-- | Determine the 'k' most probable labels for each word in the sentence. +guess :: Ord t => Int -> Guesser t -> Mx.Sent t -> [[t]] +guess k gsr sent = + let schema = fromConf (schemaConf gsr) + in CRF.tagK k (crf gsr) (schematize schema sent) + +-- | Include guessing results into weighted tag maps +-- assigned to individual words. +includeWMaps :: Ord t => Mx.Sent t -> [[t]] -> [Mx.WMap t] +includeWMaps words guessed = + [ if Mx.oov word + then addInterps (Mx.tagWMap word) xs + else Mx.tagWMap word + | (xs, word) <- zip guessed words ] + where + -- Add new interpretations. + addInterps wm xs = Mx.mkWMap + $ M.toList (Mx.unWMap wm) + ++ zip xs [0, 0 ..] + +-- | Include guessing results into the sentence. +include :: Ord t => Mx.Sent t -> [[t]] -> Mx.Sent t +include words guessed = + [ word { Mx.tagWMap = wMap } + | (word, wMap) <- zip words wMaps ] + where + wMaps = includeWMaps words guessed + +-- | Tag sentence in external format. Selected interpretations +-- (tags correct within the context) will be preserved. +guessSent :: F.Sent s w -> Int -> Guesser F.Tag -> s -> s +guessSent F.Sent{..} k gsr sent = flip mergeSent sent + [ select wMap word + | (wMap, word) <- zip wMaps (parseSent sent) ] + where + -- Extract word handler. + F.Word{..} = wordHandler + -- Word in internal format. + words = map extract (parseSent sent) + -- Guessed lists of interpretations for individual words. + guessed = guess k gsr words + -- Resultant weighted maps. + wMaps = includeWMaps words guessed + +-- | Tag file. +guessDoc + :: Functor f + => F.Doc f s w -- ^ Document format handler + -> Int -- ^ Guesser argument + -> Guesser F.Tag -- ^ Guesser itself + -> L.Text -- ^ Input + -> L.Text -- ^ Output +guessDoc F.Doc{..} k gsr + = showDoc + . fmap (guessSent sentHandler k gsr) + . parseDoc + +-- | Training configuration. +data TrainConf = TrainConf + { schemaConfT :: SchemaConf + , sgdArgsT :: SGD.SgdArgs } + +-- | Train guesser. +train + :: Foldable f + => F.Doc f s w -- ^ Document format handler + -> TrainConf -- ^ Training configuration + -> FilePath -- ^ Training file + -> Maybe FilePath -- ^ Maybe eval file + -> IO (Guesser F.Tag) +train format TrainConf{..} trainPath evalPath'Maybe = do + let schema = fromConf schemaConfT + crf <- CRF.train sgdArgsT + (schemed format schema trainPath) + (schemed format schema <$> evalPath'Maybe) + (const CRF.presentFeats) + return $ Guesser schemaConfT crf + +-- | Schematized data from the plain file. +schemed + :: Foldable f => F.Doc f s w -> Schema F.Tag a + -> FilePath -> IO [CRF.SentL Ob F.Tag] +schemed F.Doc{..} schema path = + foldMap onSent . parseDoc <$> L.readFile path + where + F.Sent{..} = sentHandler + F.Word{..} = wordHandler + onSent sent = + let xs = map extract (parseSent sent) + mkProb = CRF.mkProb . M.toList . Mx.unWMap . Mx.tagWMap + in [zip (schematize schema xs) (map mkProb xs)] diff --git a/src/NLP/Concraft/Morphosyntax.hs b/src/NLP/Concraft/Morphosyntax.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Morphosyntax.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Types and functions related to the morphosyntax data layer. + +module NLP.Concraft.Morphosyntax +( +-- * Morphosyntax data + Sent +, Word (..) +, mapWord +, mapSent +, interpsSet +, interps +-- * Weighted collection +, WMap (unWMap) +, mkWMap +, mapWMap +) where + +import Control.Arrow (first) +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Text as T + + +-- | A sentence of 'Word's. +type Sent t = [Word t] + +-- | A word parametrized over a tag type. +data Word t = Word { + -- | Orthographic form. + orth :: T.Text + -- | Set of word interpretations. To each interpretation + -- a weight of correctness within the context is assigned. + , tagWMap :: WMap t + -- | Out-of-vocabulary (OOV) word, i.e. word unknown to the + -- morphosyntactic analyser. + , oov :: Bool } + deriving (Show, Eq, Ord) + +-- | Map function over word tags. +mapWord :: Ord b => (a -> b) -> Word a -> Word b +mapWord f w = w { tagWMap = mapWMap f (tagWMap w) } + +-- | Map function over sentence tags. +mapSent :: Ord b => (a -> b) -> Sent a -> Sent b +mapSent = map . mapWord + +-- | Interpretations of the word. +interpsSet :: Word t -> S.Set t +interpsSet = M.keysSet . unWMap . tagWMap + +-- | Interpretations of the word. +interps :: Word t -> [t] +interps = S.toList . interpsSet + + +-- | A weighted collection of type @a@ elements. +newtype WMap a = WMap { unWMap :: M.Map a Double } + deriving (Show, Eq, Ord) + +-- | Make a weighted collection. +mkWMap :: Ord a => [(a, Double)] -> WMap a +mkWMap = WMap . M.fromListWith (+) . filter ((>=0).snd) + +-- | Map function over weighted collection elements. +mapWMap :: Ord b => (a -> b) -> WMap a -> WMap b +mapWMap f = mkWMap . map (first f) . M.toList . unWMap diff --git a/src/NLP/Concraft/Schema.hs b/src/NLP/Concraft/Schema.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Schema.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Observation schema blocks for Concraft. + +module NLP.Concraft.Schema +( +-- * Types + Ob +, Ox +, Schema +, void +, sequenceS_ + +-- * Usage +, schematize + +-- * Configuration +, Body (..) +, Entry +, entry +, entryWith +, SchemaConf (..) +, nullConf +, fromConf + +, guessConfDefault +, disambConfDefault + +-- * Schema blocks +, Block +, fromBlock +, orthB +, lowOrthB +, lowPrefixesB +, lowSuffixesB +, knownB +, shapeB +, packedB +, begPackedB +) where + +import Control.Applicative ((<$>), (<*>), pure) +import Control.Monad (forM_) +import Data.Binary (Binary, put, get) +import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Control.Monad.Ox as Ox +import qualified Control.Monad.Ox.Text as Ox + +import qualified NLP.Concraft.Morphosyntax as Mx + +-- | An observation consist of an index (of list type) and an actual +-- observation value. +type Ob = ([Int], T.Text) + +-- | The Ox monad specialized to word token type and text observations. +type Ox t a = Ox.Ox (Mx.Word t) T.Text a + +-- | A schema is a block of the Ox computation performed within the +-- context of the sentence and the absolute sentence position. +type Schema t a = V.Vector (Mx.Word t) -> Int -> Ox t a + +-- | A dummy schema block. +void :: a -> Schema t a +void x _ _ = return x + +-- | Sequence the list of schemas (or blocks) and discard individual values. +sequenceS_ + :: [V.Vector (Mx.Word t) -> a -> Ox t b] + -> V.Vector (Mx.Word t) -> a -> Ox t () +sequenceS_ xs sent = + let ys = map ($sent) xs + in \k -> sequence_ (map ($k) ys) + +-- | Record structure of the basic observation types. +data BaseOb = BaseOb + { orth :: Int -> Maybe T.Text + , lowOrth :: Int -> Maybe T.Text } + +-- | Construct the 'BaseOb' structure given the sentence. +mkBaseOb :: V.Vector (Mx.Word t) -> BaseOb +mkBaseOb sent = BaseOb + { orth = _orth + , lowOrth = _lowOrth } + where + at = Ox.atWith sent + _orth = (Mx.orth `at`) + _lowOrth i = T.toLower <$> _orth i + +-- | A block is a chunk of the Ox computation performed within the +-- context of the sentence and the list of absolute sentence positions. +type Block t a = V.Vector (Mx.Word t) -> [Int] -> Ox t a + +-- | Transform a block to a schema depending on +-- * A list of relative sentence positions, +-- * A boolean value; if true, the block computation +-- will be performed only on positions where an OOV +-- word resides. +fromBlock :: Block t a -> [Int] -> Bool -> Schema t a +fromBlock blk xs oovOnly sent = + \k -> blkSent [x + k | x <- xs, oov (x + k)] + where + blkSent = blk sent + oov k = if not oovOnly + then True + else maybe False id $ Mx.oov `at` k + at = Ox.atWith sent + +-- | Orthographic form at the current position. +orthB :: Block t () +orthB sent = \ks -> + let orthOb = Ox.atWith sent Mx.orth + in mapM_ (Ox.save . orthOb) ks + +-- | Orthographic form at the current position. +lowOrthB :: Block t () +lowOrthB sent = \ks -> + let BaseOb{..} = mkBaseOb sent + in mapM_ (Ox.save . lowOrth) ks + +-- | List of lowercased prefixes of given lengths. +lowPrefixesB :: [Int] -> Block t () +lowPrefixesB ns sent = \ks -> + forM_ ks $ \i -> + mapM_ (Ox.save . lowPrefix i) ns + where + BaseOb{..} = mkBaseOb sent + lowPrefix i j = Ox.prefix j =<< lowOrth i + +-- | List of lowercased suffixes of given lengths. +lowSuffixesB :: [Int] -> Block t () +lowSuffixesB ns sent = \ks -> + forM_ ks $ \i -> + mapM_ (Ox.save . lowSuffix i) ns + where + BaseOb{..} = mkBaseOb sent + lowSuffix i j = Ox.suffix j =<< lowOrth i + +-- | Shape of the word. +knownB :: Block t () +knownB sent = \ks -> do + mapM_ (Ox.save . knownAt) ks + where + at = Ox.atWith sent + knownAt i = boolF <$> (not . Mx.oov) `at` i + boolF True = "T" + boolF False = "F" + +-- | Shape of the word. +shapeB :: Block t () +shapeB sent = \ks -> do + mapM_ (Ox.save . shape) ks + where + BaseOb{..} = mkBaseOb sent + shape i = Ox.shape <$> orth i + +-- | Packed shape of the word. +packedB :: Block t () +packedB sent = \ks -> do + mapM_ (Ox.save . shapeP) ks + where + BaseOb{..} = mkBaseOb sent + shape i = Ox.shape <$> orth i + shapeP i = Ox.pack <$> shape i + +-- | Packed shape of the word. +begPackedB :: Block t () +begPackedB sent = \ks -> do + mapM_ (Ox.save . begPacked) ks + where + BaseOb{..} = mkBaseOb sent + shape i = Ox.shape <$> orth i + shapeP i = Ox.pack <$> shape i + begPacked i = isBeg i <> pure "-" <> shapeP i + isBeg i = (Just . boolF) (i == 0) + boolF True = "T" + boolF False = "F" + x <> y = T.append <$> x <*> y + +-- -- | Combined shapes of two consecutive (at @k-1@ and @k@ positions) words. +-- shapePairB :: Block t () +-- shapePairB sent = \ks -> +-- forM_ ks $ \i -> do +-- Ox.save $ link <$> shape i <*> shape (i - 1) +-- where +-- BaseOb{..} = mkBaseOb sent +-- shape i = Ox.shape <$> orth i +-- link x y = T.concat [x, "-", y] +-- +-- -- | Combined packed shapes of two consecutive (at @k-1@ and @k@ positions) +-- -- words. +-- packedPairB :: Block t () +-- packedPairB sent = \ks -> +-- forM_ ks $ \i -> do +-- Ox.save $ link <$> shapeP i <*> shapeP (i - 1) +-- where +-- BaseOb{..} = mkBaseOb sent +-- shape i = Ox.shape <$> orth i +-- shapeP i = Ox.pack <$> shape i +-- link x y = T.concat [x, "-", y] + +-- | Body of configuration entry. +data Body a = Body { + -- | Range argument for the schema block. + range :: [Int] + -- | When true, the entry is used only for oov words. + , oovOnly :: Bool + -- | Additional arguments for the schema block. + , args :: a } + deriving (Show) + +instance Binary a => Binary (Body a) where + put Body{..} = put range >> put oovOnly >> put args + get = Body <$> get <*> get <*> get + +-- | Maybe entry. +type Entry a = Maybe (Body a) + +-- | Entry with additional arguemnts. +entryWith :: a -> [Int] -> Entry a +entryWith v xs = Just (Body xs False v) + +-- | Plain entry with no additional arugments. +entry :: [Int] -> Entry () +entry = entryWith () + +-- | Configuration of the schema. All configuration elements specify the +-- range over which a particular observation type should be taken on account. +-- For example, the @[-1, 0, 2]@ range means that observations of particular +-- type will be extracted with respect to previous (@k - 1@), current (@k@) +-- and after the next (@k + 2@) positions when identifying the observation +-- set for position @k@ in the input sentence. +data SchemaConf = SchemaConf { + -- | The 'orthB' schema block. + orthC :: Entry () + -- | The 'lowOrthB' schema block. + , lowOrthC :: Entry () + -- | The 'lowPrefixesB' schema block. The first list of ints + -- represents lengths of prefixes. + , lowPrefixesC :: Entry [Int] + -- | The 'lowSuffixesB' schema block. The first list of ints + -- represents lengths of suffixes. + , lowSuffixesC :: Entry [Int] + -- | The 'knownB' schema block. + , knownC :: Entry () + -- | The 'shapeB' schema block. + , shapeC :: Entry () + -- | The 'packedB' schema block. + , packedC :: Entry () + -- | The 'begPackedB' schema block. + , begPackedC :: Entry () + } deriving (Show) + +instance Binary SchemaConf where + put SchemaConf{..} = do + put orthC + put lowOrthC + put lowPrefixesC + put lowSuffixesC + put knownC + put shapeC + put packedC + put begPackedC + get = SchemaConf + <$> get <*> get <*> get <*> get + <*> get <*> get <*> get <*> get + +-- | Null configuration of the observation schema. +nullConf :: SchemaConf +nullConf = SchemaConf + Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + +mkArg0 :: Block t () -> Entry () -> Schema t () +mkArg0 blk (Just x) = fromBlock blk (range x) (oovOnly x) +mkArg0 _ Nothing = void () + +mkArg1 :: (a -> Block t ()) -> Entry a -> Schema t () +mkArg1 blk (Just x) = fromBlock (blk (args x)) (range x) (oovOnly x) +mkArg1 _ Nothing = void () + +-- | Build the schema based on the configuration. +fromConf :: SchemaConf -> Schema t () +fromConf SchemaConf{..} = sequenceS_ + [ mkArg0 orthB orthC + , mkArg0 lowOrthB lowOrthC + , mkArg1 lowPrefixesB lowPrefixesC + , mkArg1 lowSuffixesB lowSuffixesC + , mkArg0 knownB knownC + , mkArg0 shapeB shapeC + , mkArg0 packedB packedC + , mkArg0 begPackedB begPackedC ] + +-- -- | Use the schema to extract observations from the sentence. +-- schematize :: Schema t a -> [Mx.Word t] -> CRF.Sent Ob +-- schematize schema xs = +-- map (S.fromList . Ox.execOx . schema v) [0 .. n - 1] +-- where +-- v = V.fromList xs +-- n = V.length v + +--------------------------------- +-- Default schema configurations. +--------------------------------- + +-- | Default configuration for the guessing observation schema. +guessConfDefault :: SchemaConf +guessConfDefault = nullConf + { lowPrefixesC = entryWith [1, 2] [0] + , lowSuffixesC = entryWith [1, 2] [0] + , knownC = entry [0] + , begPackedC = entry [0] } + +-- -- | Default guessing schema. +-- guessSchemaDefault :: Schema t () +-- guessSchemaDefault sent = \k -> do +-- mapM_ (Ox.save . lowPref k) [1, 2] +-- mapM_ (Ox.save . lowSuff k) [1, 2] +-- Ox.save (knownAt k) +-- Ox.save (isBeg k <> pure "-" <> shapeP k) +-- where +-- at = Ox.atWith sent +-- lowOrth i = T.toLower <$> Mx.orth `at` i +-- lowPref i j = Ox.prefix j =<< lowOrth i +-- lowSuff i j = Ox.suffix j =<< lowOrth i +-- shape i = Ox.shape <$> Mx.orth `at` i +-- shapeP i = Ox.pack <$> shape i +-- knownAt i = boolF <$> (not . Mx.oov) `at` i +-- isBeg i = (Just . boolF) (i == 0) +-- boolF True = "T" +-- boolF False = "F" +-- x <> y = T.append <$> x <*> y + +-- | Default configuration for the guessing observation schema. +disambConfDefault :: SchemaConf +disambConfDefault = nullConf + { lowOrthC = entry [-1, 0, 1] + , lowPrefixesC = oov $ entryWith [1, 2, 3] [0] + , lowSuffixesC = oov $ entryWith [1, 2, 3] [0] + , begPackedC = oov $ entry [0] } + where + oov (Just body) = Just $ body { oovOnly = True } + oov Nothing = Nothing + +-- -- | Default disambiguation schema. +-- disambSchemaDefault :: Schema t () +-- disambSchemaDefault sent = \k -> do +-- mapM_ (Ox.save . lowOrth) [k - 1, k, k + 1] +-- _ <- Ox.whenJT (Mx.oov `at` k) $ do +-- mapM_ (Ox.save . lowPref k) [1, 2, 3] +-- mapM_ (Ox.save . lowSuff k) [1, 2, 3] +-- Ox.save (isBeg k <> pure "-" <> shapeP k) +-- return () +-- where +-- at = Ox.atWith sent +-- lowOrth i = T.toLower <$> Mx.orth `at` i +-- lowPref i j = Ox.prefix j =<< lowOrth i +-- lowSuff i j = Ox.suffix j =<< lowOrth i +-- shape i = Ox.shape <$> Mx.orth `at` i +-- shapeP i = Ox.pack <$> shape i +-- isBeg i = (Just . boolF) (i == 0) +-- boolF True = "T" +-- boolF False = "F" +-- x <> y = T.append <$> x <*> y + +-- | Use the schema to extract observations from the sentence. +schematize :: Schema t a -> Mx.Sent t -> [[Ob]] +schematize schema xs = + map (Ox.execOx . schema v) [0 .. n - 1] + where + v = V.fromList xs + n = V.length v diff --git a/tools/concraft.hs b/tools/concraft.hs --- a/tools/concraft.hs +++ b/tools/concraft.hs @@ -5,8 +5,7 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad (when) import System.Console.CmdArgs -import Data.Binary (Binary, put, get, encodeFile, decodeFile) -import Data.Text.Binary () +import Data.Binary (encodeFile, decodeFile) import qualified Numeric.SGD as SGD import qualified Data.Text as T import qualified Data.Text.Lazy.IO as L @@ -15,29 +14,12 @@ import NLP.Concraft.Format.Plain (plainFormat) import qualified NLP.Concraft as C import qualified NLP.Concraft.Schema as S -import qualified NLP.Concraft.Format as F import qualified NLP.Concraft.Guess as G -import qualified NLP.Concraft.Disamb.Positional as D -import qualified NLP.Concraft.Disamb.Tiered as R +import qualified NLP.Concraft.Disamb as D -- | Data formats. data Format = Plain deriving (Data, Typeable, Show) --- | Concraft data. -data ConcraftData = ConcraftData - { guesser :: G.Guesser F.Tag - , disambModel :: R.CRF S.Ob D.Part - , tagset :: P.Tagset - , tierConf :: [D.Tier] } - -instance Binary ConcraftData where - put ConcraftData{..} = do - put guesser - put disambModel - put tagset - put tierConf - get = ConcraftData <$> get <*> get <*> get <*> get - data Concraft = Train { trainPath :: FilePath @@ -48,7 +30,7 @@ -- Try another command line parsing library? , tagsetPath :: FilePath , ignTag :: String - , discardHidden :: Bool + -- , discardHidden :: Bool , iterNum :: Double , batchSize :: Int , regVar :: Double @@ -59,8 +41,8 @@ | Disamb { format :: Format , ignTag :: String - , inModel :: FilePath - , guessNum :: Int } + , inModel :: FilePath } + -- , guessNum :: Int } deriving (Data, Typeable, Show) trainMode :: Concraft @@ -70,7 +52,7 @@ , evalPath = def &= typFile &= help "Evaluation file" , format = enum [Plain &= help "Plain format"] , ignTag = "ign" &= help "Tag indicating OOV word" - , discardHidden = False &= help "Discard hidden features" + -- , discardHidden = False &= help "Discard hidden features" , iterNum = 10 &= help "Number of SGD iterations" , batchSize = 30 &= help "Batch size" , regVar = 10.0 &= help "Regularization variance" @@ -83,8 +65,8 @@ disambMode = Disamb { inModel = def &= argPos 0 &= typ "MODEL-FILE" , format = enum [Plain &= help "Plain format"] - , ignTag = "ign" &= help "Tag indicating OOV word" - , guessNum = 10 &= help "Number of guessed tags for each unknown word" } + , ignTag = "ign" &= help "Tag indicating OOV word" } + -- , guessNum = 10 &= help "Number of guessed tags for each unknown word" } argModes :: Mode (CmdArgs Concraft) argModes = cmdArgsMode $ modes [trainMode, disambMode] @@ -95,34 +77,18 @@ exec :: Concraft -> IO () exec Train{..} = do - tagset' <- P.parseTagset tagsetPath <$> readFile tagsetPath - (guesser', disambModel') <- case format of - Plain -> doTrain (plainFormat ign) tagset' - let concraftData = ConcraftData - { guesser = guesser' - , disambModel = disambModel' - , tagset = tagset' - , tierConf = D.tierConfDefault } + tagset <- P.parseTagset tagsetPath <$> readFile tagsetPath + concraft <- case format of + Plain -> train (plainFormat ign) tagset when (not . null $ outModel) $ do putStrLn $ "\nSaving model in " ++ outModel ++ "..." - encodeFile outModel concraftData + encodeFile outModel concraft where - doTrain docHandler tagset' = C.trainOn - docHandler guessConf sgdArgs - (disambTrain tagset') - trainPath evalPath - guessConf = C.GuessConf - { C.guessNum = guessNum - , C.guessSchema = S.guessSchemaDefault } - disambTrain tagset' = C.DisambWith - { C.disambConf = disambConf tagset' - , C.disambWith = R.train (length D.tierConfDefault) featSel sgdArgs } - disambConf tagset' = C.DisambConf - { C.split = D.split D.tierConfDefault . P.parseTag tagset' - , disambSchema = S.disambSchemaDefault } - featSel = if discardHidden - then R.selectPresent - else R.selectHidden + train docH tagset = + let guessConf = G.TrainConf S.guessConfDefault sgdArgs + disambConf = D.TrainConf tagset D.tiersDefault + S.disambConfDefault sgdArgs + in C.train docH guessNum guessConf disambConf trainPath evalPath ign = T.pack ignTag sgdArgs = SGD.SgdArgs { SGD.batchSize = batchSize @@ -132,20 +98,9 @@ , SGD.tau = tau } exec Disamb{..} = do - doTag <- doTagWith <$> decodeFile inModel <*> L.getContents + tag <- tagWith <$> decodeFile inModel <*> L.getContents case format of - Plain -> L.putStr $ doTag (plainFormat ign) + Plain -> L.putStr $ tag (plainFormat ign) where - doTagWith ConcraftData{..} input docHandler = - let guessData = C.GuessData - { C.guessConf = C.GuessConf - { C.guessNum = guessNum - , guessSchema = S.guessSchemaDefault } - , C.guesser = guesser } - disambTag = C.DisambWith - { C.disambConf = C.DisambConf - { C.split = D.split tierConf . P.parseTag tagset - , C.disambSchema = S.disambSchemaDefault } - , C.disambWith = R.tag disambModel } - in C.disambDoc docHandler guessData disambTag input + tagWith concraft input docH = C.tagDoc docH concraft input ign = T.pack ignTag