concraft 0.7.3 → 0.8.0
raw patch · 4 files changed
+57/−96 lines, 4 filesdep −Chartdep −colourdep −data-accessordep ~crf-chain1-constrained
Dependencies removed: Chart, colour, data-accessor
Dependency ranges changed: crf-chain1-constrained
Files
- concraft.cabal +3/−5
- src/NLP/Concraft/Guess.hs +34/−5
- src/NLP/Concraft/Morphosyntax.hs +2/−2
- tools/concraft-analyse-model.hs +18/−84
concraft.cabal view
@@ -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
src/NLP/Concraft/Guess.hs view
@@ -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)
src/NLP/Concraft/Morphosyntax.hs view
@@ -15,7 +15,7 @@ , interpsSet , interps --- * Word classes+-- * Word class , Word (..) -- * Sentence@@ -85,7 +85,7 @@ ----------------------------- Word classes+-- Word class --------------------------
tools/concraft-analyse-model.hs view
@@ -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 ((<maxVal) . abs . snd) (M.assocs featMap)++ putStrLn "type param"+ forM_ xs $ \(feat, param) -> do+ putStrLn $ featType feat ++ " " ++ show param