concraft (empty) → 0.1.0

raw patch · 7 files changed

+534/−0 lines, 7 filesdep +basedep +binarydep +cmdargssetup-changed

Dependencies added: base, binary, cmdargs, containers, crf-chain1-constrained, monad-ox, sgd, text, text-binary, vector

Files

LICENSE +26/−0
NLP/Concraft/Guess.hs +131/−0
NLP/Concraft/Morphosyntax.hs +57/−0
NLP/Concraft/Plain.hs +196/−0
Setup.lhs +4/−0
concraft.cabal +46/−0
tools/concraft-guess.hs +74/−0

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright (c) 2011 Jakub Waszczuk, 2012 IPI PAN+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ NLP/Concraft/Guess.hs view

@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module NLP.Concraft.Guess+( Ox+, Schema+, Ob+, schema+, schematize+, Guesser (..)+, guess+, tagFile+, learn+) where++import Control.Applicative (pure, (<$>), (<*>))+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Vector as V++import Data.Binary (Binary, get, put)+import Data.Text.Binary ()++import qualified Control.Monad.Ox as Ox+import qualified Control.Monad.Ox.Text as Ox+import qualified Data.CRF.Chain1.Constrained as CRF+import qualified Numeric.SGD as SGD++import NLP.Concraft.Morphosyntax+import qualified NLP.Concraft.Plain as P++-- | The Ox monad specialized to word token type and text observations.+-- TODO: Move to monad-ox package from here and from the nerf library.+type Ox t a = Ox.Ox (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 (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)++schema :: Schema t ()+schema 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 <$> orth `at` i+    lowPref i j = Ox.prefix j =<< lowOrth i+    lowSuff i j = Ox.suffix j =<< lowOrth i+    shape i     = Ox.shape <$> orth `at` i+    shapeP i    = Ox.pack <$> shape i+    knownAt i   = boolF <$> known `at` i+    isBeg i     = (Just . boolF) (i == 0)+    boolF True  = "T"+    boolF False = "F"+    x <> y      = T.append <$> x <*> y++-- | Schematize the input sentence with according to 'schema' rules.+schematize :: Ord t => Sent t -> CRF.Sent Ob t+schematize 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 = tags . (v V.!)++-- | A guesser represented by the conditional random field.+data Guesser t = Guesser+    { crf   :: CRF.CRF Ob t -- ^ The CRF model+    , ign   :: t            -- ^ The tag indicating unkown words+    }++instance (Ord t, Binary t) => Binary (Guesser t) where+    put Guesser{..} = put crf >> put ign+    get = Guesser <$> get <*> get++-- | Determine the 'k' most probable labels for each unknown word+-- in the sentence.+guess :: Ord t => Int -> Guesser t -> Sent t -> [[t]]+guess k gsr sent = CRF.tagK k (crf gsr) (schematize sent)+{-# INLINE guess #-}++-- | Tag the file.+tagFile+    :: Int              -- ^ Guesser argument+    -> Guesser T.Text   -- ^ Guesser itself+    -> FilePath         -- ^ File to tag (plain format)+    -> IO L.Text+tagFile k gsr path =+    P.showPlain (ign gsr) . map onSent <$> P.readPlain (ign gsr) path+  where+    onSent sent =+        let (xs, _) = unzip (map P.fromTok sent)+            yss = guess k gsr xs+        in  [ if P.known tok+                then tok+                else P.addNones False tok ys+            | (tok, ys) <- zip sent yss ]++-- | TODO: Abstract over the format type.+learn+    :: SGD.SgdArgs      -- ^ SGD parameters +    -> T.Text        	-- ^ The tag indicating unknown words+    -> FilePath         -- ^ Train file (plain format)+    -> Maybe FilePath   -- ^ Maybe eval file+    -> IO (Guesser T.Text)+learn sgdArgs _ign trainPath evalPath'Maybe = do+    _crf <- CRF.train sgdArgs+        (schemed _ign trainPath)+        (schemed _ign <$> evalPath'Maybe)+        (const CRF.presentFeats)+    return $ Guesser _crf _ign++-- | Schematized data from the plain file.+schemed :: T.Text -> FilePath -> IO [CRF.SentL Ob T.Text]+schemed _ign =+    fmap (map onSent) . P.readPlain _ign+  where+    onSent sent =+        let (xs, ys) = unzip (map P.fromTok sent)+            mkDist = CRF.mkDist . M.toList . M.map unPositive+        in  zip (schematize xs) (map mkDist ys)

+ NLP/Concraft/Morphosyntax.hs view

@@ -0,0 +1,57 @@+module NLP.Concraft.Morphosyntax+( Word (..)+, Sent+, Choice+, Positive (unPositive)+, (<+>)+, mkPositive+, best+, known+) where++import Data.Ord (comparing)+import Data.List (maximumBy)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T++-- | A word parametrized over the tag type.+data Word t = Word {+    -- | Orthographic form.+      orth  :: T.Text+    -- | Set of word interpretations.+    , tags  :: S.Set t }+    deriving (Show, Read, Eq, Ord)++-- | A sentence of 'Word's.+type Sent t = [Word t]++-- | Interpretations chosen in the given context with+-- corresponding positive weights.+type Choice t = M.Map t (Positive Double)++-- | Positive number.+newtype Positive a = Positive { unPositive :: a }+    deriving (Show, Eq, Ord)++(<+>) :: Num a => Positive a -> Positive a -> Positive a+Positive x <+> Positive y = Positive (x + y)+{-# INLINE (<+>) #-}++mkPositive :: (Num a, Ord a) => a -> Positive a+mkPositive x+    | x > 0     = Positive x+    | otherwise = error "mkPositive: not a positive number"+{-# INLINE mkPositive #-}++-- | Retrieve the most probable interpretation.+best :: Choice t -> t+best c+    | M.null c  = error "best: null choice" +    | otherwise = fst . maximumBy (comparing snd) $ M.toList c++-- | A word is considered to be known when the set of possible+-- interpretations is not empty.+known :: Word t -> Bool+known = not . S.null . tags+{-# INLINE known #-}

+ NLP/Concraft/Plain.hs view

@@ -0,0 +1,196 @@+{-# 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.Plain+(+-- * Types+  Space (..)+, Token (..)+, Interp (..)++-- * Interface+, fromTok+, choose+, addInterps+, addNones++-- * Parsing+, readPlain+, parsePlain+, parseSent++-- * Showing+, writePlain+, showPlain+, showSent+, showWord+) where++import Data.Monoid (Monoid, mappend, mconcat)+import Data.Maybe (catMaybes)+import Data.List (groupBy)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L+import qualified Data.Text.Lazy.Builder as L++import qualified NLP.Concraft.Morphosyntax as Mx++-- | 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 with disambiguation info.+    , interps   :: M.Map Interp Bool }+    deriving (Show, Eq, Ord)+    +data Interp = Interp+    { base      :: T.Text+    , tag       :: T.Text }+    deriving (Show, Eq, Ord)++-- | Extract information relevant for tagging.+fromTok :: Token -> (Mx.Word T.Text, Mx.Choice T.Text)+fromTok tok =+    (word, choice)+  where+    word = Mx.Word+        { Mx.orth   = orth tok+        , Mx.tags   = if known tok+            then S.fromList . map tag . M.keys $ interps tok+            else S.empty }+    choice = M.fromListWith (Mx.<+>)+        [ (tag x, Mx.mkPositive 1)+        | (x, True) <- M.toList (interps tok) ]++-- | Mark all interpretations with tag component beeing a member of+-- the given choice set with disamb annotations.+choose :: Token -> S.Set T.Text -> Token+choose tok choice =+    tok { interps = (M.fromList . map mark . M.keys) (interps tok) }+  where+    mark ip +        | tag ip `S.member` choice  = (ip, True) +        | otherwise                 = (ip, False)++-- | Add new interpretations with given disamb annotation.+addInterps :: Bool -> Token -> [Interp] -> Token+addInterps dmb tok xs =+    let newIps = M.fromList [(x, dmb) | x <- xs]+    in  tok { interps = M.unionWith max newIps (interps tok) }++-- | Add new interpretations with "None" base and given disamb annotation.+addNones :: Bool -> Token -> [T.Text] -> Token+addNones dmb tok = addInterps dmb tok . map (Interp "None")++readPlain :: T.Text -> FilePath -> IO [[Token]]+readPlain ign = fmap (parsePlain ign) . L.readFile++parsePlain :: T.Text -> L.Text -> [[Token]]+parsePlain ign = map (parseSent ign) . init . L.splitOn "\n\n"++parseSent :: T.Text -> 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.fromList (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 = Interp (L.toStrict form) (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 "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 (<>) #-}++writePlain :: T.Text -> FilePath -> [[Token]] -> IO ()+writePlain ign path = L.writeFile path . showPlain ign ++showPlain :: T.Text -> [[Token]] -> L.Text+showPlain ign =+    L.toLazyText . mconcat  . map (\xs -> buildSent ign xs <> "\n")++showSent :: T.Text -> [Token] -> L.Text+showSent ign = L.toLazyText . buildSent ign++showWord :: T.Text -> Token -> L.Text+showWord ign = L.toLazyText . buildWord ign++buildSent :: T.Text -> [Token] -> L.Builder+buildSent ign = mconcat . map (buildWord ign)++buildWord :: T.Text -> 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" <> L.fromText _base <>+      "\t" <> L.fromText _tag <>+      if dmb+        then "\tdisamb\n"+        else "\n"+    | (Interp _base _tag, dmb) <- interps ]++buildSpace :: Space -> L.Builder+buildSpace None     = "none"+buildSpace Space    = "space"+buildSpace NewLine  = "newline"++buildKnown :: T.Text -> Bool -> L.Builder+buildKnown _ True       = ""+buildKnown ign False    = "\tNone\t" <> L.fromText ign <> "\n"

+ Setup.lhs view

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

+ concraft.cabal view

@@ -0,0 +1,46 @@+name:               concraft+version:            0.1.0+synopsis:           Morphosyntactic tagging tool based on constrained CRFs+description:+    A morphosyntactic tagging tool based on constrained conditional+    random fields.+license:            BSD3+license-file:       LICENSE+cabal-version:      >= 1.6+copyright:          Copyright (c) 2011 Jakub Waszczuk, 2012 IPI PAN+author:             Jakub Waszczuk+maintainer:         waszczuk.kuba@gmail.com+stability:          experimental+category:           Natural Language Processing+homepage:           https://github.com/kawu/concraft+build-type:         Simple++library+    build-depends:+        base >= 4 && < 5+      , containers+      , binary+      , text+      , text-binary >= 0.1 && < 0.2+      , vector+      , crf-chain1-constrained >= 0.1.1 && < 0.2+      , monad-ox >= 0.2 && < 0.3+      , sgd >= 0.2.2 && < 0.3++    exposed-modules:+        NLP.Concraft.Morphosyntax+      , NLP.Concraft.Guess+      , NLP.Concraft.Plain++    ghc-options: -Wall -O2++source-repository head+    type: git+    location: git://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

+ tools/concraft-guess.hs view

@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}++import Control.Monad (when)+import System.Console.CmdArgs+import Data.Binary (encodeFile, decodeFile)+import Data.Text.Binary ()+import qualified Numeric.SGD as SGD+import qualified Data.Text as T+import qualified Data.Text.Lazy.IO as L++import NLP.Concraft.Guess (learn, tagFile)++data Args+  = LearnMode+    { learnPath	    :: FilePath+    , evalPath      :: Maybe FilePath+    , ignTag        :: String+    , iterNum       :: Double+    , batchSize     :: Int+    , regVar        :: Double+    , gain0         :: Double+    , tau           :: Double+    , outGuesser    :: FilePath }+  | TagMode+    { dataPath      :: FilePath+    , inGuesser     :: FilePath+    , guessNum      :: Int }+  deriving (Data, Typeable, Show)++learnMode :: Args+learnMode = LearnMode+    { ignTag = def &= argPos 0 &= typ "IGN-TAG"+    , learnPath = def &= argPos 1 &= typ "TRAIN-FILE"+    , evalPath = def &= typFile &= help "Evaluation file"+    , iterNum = 10 &= help "Number of SGD iterations"+    , batchSize = 30 &= help "Batch size"+    , regVar = 10.0 &= help "Regularization variance"+    , gain0 = 1.0 &= help "Initial gain parameter"+    , tau = 5.0 &= help "Initial tau parameter"+    , outGuesser = def &= typFile &= help "Output Guesser file" }++tagMode :: Args+tagMode = TagMode+    { inGuesser = def &= argPos 0 &= typ "GUESSER-FILE"+    , dataPath = def &= argPos 1 &= typ "INPUT"+    , guessNum = 10 &= help "Number of guessed tags for each unknown word" }++argModes :: Mode (CmdArgs Args)+argModes = cmdArgsMode $ modes [learnMode, tagMode]++main :: IO ()+main = exec =<< cmdArgsRun argModes++exec :: Args -> IO ()++exec LearnMode{..} = do+    gsr <- learn sgdArgs (T.pack ignTag) learnPath evalPath+    when (not . null $ outGuesser) $ do+        putStrLn $ "\nSaving model in " ++ outGuesser ++ "..."+        encodeFile outGuesser gsr+  where+    sgdArgs = SGD.SgdArgs+        { SGD.batchSize = batchSize+        , SGD.regVar = regVar+        , SGD.iterNum = iterNum+        , SGD.gain0 = gain0+        , SGD.tau = tau }++exec TagMode{..} = do+    gsr <- decodeFile inGuesser+    L.putStr =<< tagFile guessNum gsr dataPath