diff --git a/concraft.cabal b/concraft.cabal --- a/concraft.cabal +++ b/concraft.cabal @@ -1,5 +1,5 @@ name: concraft -version: 0.7.3 +version: 0.8.0 synopsis: Morphological disambiguation based on constrained CRFs description: A morphological disambiguation library based on @@ -35,7 +35,7 @@ , monad-ox >= 0.3 && < 0.4 , sgd >= 0.3.2 && < 0.4 , tagset-positional >= 0.3 && < 0.4 - , crf-chain1-constrained >= 0.2.1 && < 0.3 + , crf-chain1-constrained >= 0.3 && < 0.4 , crf-chain2-tiers >= 0.1.1 && < 0.2 , monad-codec >= 0.2 && < 0.3 , data-lens @@ -45,6 +45,7 @@ , aeson >= 0.6 && < 0.7 , zlib >= 0.5 && < 0.6 , lazy-io + , cmdargs >= 0.10 && < 0.11 exposed-modules: NLP.Concraft @@ -72,9 +73,6 @@ build-depends: cmdargs >= 0.10 && < 0.11 , logfloat - , Chart - , data-accessor - , colour else buildable: False hs-source-dirs: src, tools diff --git a/src/NLP/Concraft/Guess.hs b/src/NLP/Concraft/Guess.hs --- a/src/NLP/Concraft/Guess.hs +++ b/src/NLP/Concraft/Guess.hs @@ -1,5 +1,7 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} + module NLP.Concraft.Guess ( -- * Types @@ -12,13 +14,16 @@ -- * Training , TrainConf (..) +, R0T (..) , train ) where + import Prelude hiding (words) import Control.Applicative ((<$>), (<*>)) import Data.Binary (Binary, put, get) import Data.Text.Binary () +import System.Console.CmdArgs import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Vector as V @@ -30,15 +35,18 @@ import NLP.Concraft.Schema hiding (schematize) import qualified NLP.Concraft.Morphosyntax as X + -- | 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 :: (X.Word w, Ord t) => Schema w t a -> X.Sent w t -> CRF.Sent Ob t schematize schema sent = @@ -53,6 +61,7 @@ | otherwise = X.interpsSet w where w = v V.! i + -- | Determine 'k' most probable labels for each word in the sentence. guess :: (X.Word w, Ord t) => Int -> Guesser t -> X.Sent w t -> [[t]] @@ -60,6 +69,7 @@ let schema = fromConf (schemaConf gsr) in CRF.tagK k (crf gsr) (schematize schema sent) + -- | Insert guessing results into the sentence. include :: (X.Word w, Ord t) => (X.Sent w t -> [[t]]) -> X.Sent w t -> X.Sent w t @@ -76,18 +86,32 @@ $ M.toList (X.unWMap wm) ++ zip xs [0, 0 ..] + -- | Combine `guess` with `include`. guessSent :: (X.Word w, Ord t) => Int -> Guesser t -> X.Sent w t -> X.Sent w t guessSent guessNum guesser = include (guess guessNum guesser) + +-- | Method of constructing the default set of labels (R0). +data R0T + = AnyInterps -- ^ See `CRF.anyInterps` + | AnyChosen -- ^ See `CRF.anyChosen` + | OovChosen -- ^ See `CRF.oovChosen` + deriving (Show, Eq, Ord, Enum, Typeable, Data) + + -- | Training configuration. data TrainConf = TrainConf { schemaConfT :: SchemaConf + -- | SGD parameters. , sgdArgsT :: SGD.SgdArgs - -- | Store SGD dataset on disk. - , onDiskT :: Bool } + -- | Store SGD dataset on disk + , onDiskT :: Bool + -- | R0 construction method + , r0T :: R0T } + -- | Train guesser. train :: (X.Word w, Ord t) @@ -97,13 +121,17 @@ -> IO (Guesser t) train TrainConf{..} trainData evalData = do let schema = fromConf schemaConfT + mkR0 = case r0T of + AnyInterps -> CRF.anyInterps + AnyChosen -> CRF.anyChosen + OovChosen -> CRF.oovChosen crf <- CRF.train sgdArgsT onDiskT + mkR0 (const CRF.presentFeats) (schemed schema <$> trainData) (schemed schema <$> evalData) - (const CRF.presentFeats) return $ Guesser schemaConfT crf - where + -- | Schematized dataset. schemed :: (X.Word w, Ord t) => Schema w t a -> [X.Sent w t] -> [CRF.SentL Ob t] @@ -112,4 +140,5 @@ where onSent xs = let mkProb = CRF.mkProb . M.toList . X.unWMap . X.tags - in zip (schematize schema xs) (map mkProb xs) + in map (uncurry CRF.mkWordL) $ + zip (schematize schema xs) (map mkProb xs) diff --git a/src/NLP/Concraft/Morphosyntax.hs b/src/NLP/Concraft/Morphosyntax.hs --- a/src/NLP/Concraft/Morphosyntax.hs +++ b/src/NLP/Concraft/Morphosyntax.hs @@ -15,7 +15,7 @@ , interpsSet , interps --- * Word classes +-- * Word class , Word (..) -- * Sentence @@ -85,7 +85,7 @@ -------------------------- --- Word classes +-- Word class -------------------------- diff --git a/tools/concraft-analyse-model.hs b/tools/concraft-analyse-model.hs --- a/tools/concraft-analyse-model.hs +++ b/tools/concraft-analyse-model.hs @@ -3,18 +3,11 @@ {-# LANGUAGE RecordWildCards #-} import Control.Applicative ((<$>)) -import Control.Arrow (second) -import Control.Monad (void) +import Control.Monad (forM_) import System.Console.CmdArgs -import Data.List (foldl') import qualified Data.Map as M import qualified Data.Number.LogFloat as L -import Data.Colour.Names -import Data.Colour -import Data.Accessor -import Graphics.Rendering.Chart - import qualified Data.CRF.Chain2.Tiers.Model as CRF import qualified Data.CRF.Chain2.Tiers.Feature as CRF import qualified Data.CRF.Chain2.Tiers as CRF @@ -24,93 +17,21 @@ --------------------------------------- --- Histogram ---------------------------------------- - - --- | Round double value. -roundTo :: Int -> Double -> Double -roundTo n x = (fromInteger $ round $ x * (10^n)) / (10.0^^n) - - --- | Make a histogram with a given precision. -hist :: Ord a => [a] -> M.Map a Int -hist = - let update m x = M.insertWith' (+) x 1 m - in foldl' update M.empty - - ---------------------------------------- --- Rendering ---------------------------------------- - - -drawModel :: Int -> CRF.Model -> FilePath -> IO () -drawModel rnParam model filePath = do - - void $ renderableToPNGFile (toRenderable layout) 640 480 filePath - - where - - -- Feature map with values in log domain - featMap = L.logFromLogFloat <$> CRF.toMap model - - -- Values assigned to observation features - obVals = [x | (ft, x) <- M.assocs featMap, isOFeat ft] - - -- Values assigned to transition features - trVals = [x | (ft, x) <- M.assocs featMap, not (isOFeat ft)] - - -- Is it an observation feature? - isOFeat (CRF.OFeat _ _ _) = True - isOFeat _ = False - - -- Make log-domain histogram - mkHist = map (second intLog) . M.toList . hist . map (roundTo rnParam) - - obChart = - plot_lines_style .> line_color ^= opaque blue - $ plot_lines_values ^= [mkHist obVals] - $ plot_lines_title ^= "Observation features" - $ defaultPlotLines - - trChart = - plot_lines_style .> line_color ^= opaque green - $ plot_lines_values ^= [mkHist trVals] - $ plot_lines_title ^= "Transition features" - $ defaultPlotLines - - layout = - layout1_left_axis ^: laxis_override ^= axisGridHide - $ layout1_right_axis ^: laxis_override ^= axisGridHide - $ layout1_bottom_axis ^: laxis_override ^= axisGridHide - $ layout1_plots ^= [Left (toPlot obChart), Right (toPlot trChart)] - $ layout1_grid_last ^= False - $ defaultLayout1 - - --- | Int logarithm. -intLog :: Int -> Double -intLog = (log :: Double -> Double) . fromIntegral - - ---------------------------------------- -- Command line options --------------------------------------- data AnaModel = AnaModel { inModel :: FilePath - , outFile :: FilePath - , rnParam :: Int } + , maxVal :: Double } deriving (Data, Typeable, Show) anaModel :: AnaModel anaModel = AnaModel { inModel = def &= argPos 0 &= typ "MODEL-FILE" - , outFile = def &= argPos 1 &= typ "OUTPUT-FILE" - , rnParam = 1 &= help "Rounding parameter" } + , maxVal = 100 &= help "Discard parameters with absolute values greater than this argument" } + &= summary "Print Concraft model parameters in CSV format" --------------------------------------- @@ -118,11 +39,24 @@ --------------------------------------- +-- | Get feature type identifier (T -- transition, O -- observation). +featType :: CRF.Feat -> String +featType (CRF.OFeat _ _ _) = "O" +featType _ = "T" + + main :: IO () main = exec =<< cmdArgs anaModel exec :: AnaModel -> IO () exec AnaModel{..} = do + model <- CRF.model . D.crf . C.disamb <$> C.loadModel inModel - drawModel rnParam model outFile + + let featMap = L.logFromLogFloat <$> CRF.toMap model :: M.Map CRF.Feat Double + xs = filter (( do + putStrLn $ featType feat ++ " " ++ show param