packages feed

concraft-hr (empty) → 0.1.0.0

raw patch · 9 files changed

+1149/−0 lines, 9 filesdep +aesondep +basedep +binarysetup-changed

Dependencies added: aeson, base, binary, bytestring, cmdargs, concraft, containers, double-conversion, lazy-io, moan, network, sgd, split, tagset-positional, text

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2013 Jakub Waszczuk+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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ concraft-hr.cabal view
@@ -0,0 +1,61 @@+name:               concraft-hr+version:            0.1.0.0+synopsis:           Part-of-speech tagger for Croatian+description:+    A part-of-speech tagger for Croatian based on the concraft library.+license:            BSD3+license-file:       LICENSE+cabal-version:      >= 1.6++author:             Vjeran Crnjak+maintainer:         vjeran.crnjak@gmail.com+stability:          experimental+category:           Natural Language Processing+homepage:           https://github.com/vjeranc/concraft-hr+build-type:         Simple++data-files: config/tagset.cfg++library+    hs-source-dirs: src++    build-depends:+        base >= 4 && < 5+      , concraft                >= 0.9      && < 0.10+      , tagset-positional       >= 0.3      && < 0.4+      , sgd                     >= 0.3.3    && < 0.4+      , containers              >= 0.4      && < 0.6+      , bytestring              >= 0.9      && < 0.11+      , text                    >= 0.11     && < 1.2+      , aeson                   >= 0.6      && < 0.8+      , binary                  >= 0.5      && < 0.8+      , network                 >= 2.3      && < 2.7+      , lazy-io                 >= 0.1      && < 0.2+      , split                   >= 0.2      && < 0.3+      , moan                    >= 0.2      && < 0.3+      , double-conversion       >= 2.0      && < 2.1++    exposed-modules:+        NLP.Concraft.Croatian+      , NLP.Concraft.Croatian.Morphosyntax+      , NLP.Concraft.Croatian.Request+      , NLP.Concraft.Croatian.Server++    other-extensions:+        OverloadedStrings+      , TupleSections+      , DeriveGeneric+      , FlexibleInstances+      , RecordWildCards+    ghc-options: -Wall -O2++source-repository head+    type: git+    location: https://github.com/vjeranc/concraft-hr.git++executable concraft-hr+    build-depends:+        cmdargs                 >= 0.10     && < 0.11+    hs-source-dirs: src, tools+    main-is: concraft-hr.hs+    ghc-options: -Wall -O2 -threaded -rtsopts
+ config/tagset.cfg view
@@ -0,0 +1,139 @@+# Croatian MULTEXTEast v4 tagset definition++# MSDs for Croatian are a single entity (ex. Ncmsnn).+# For concraft MSD string must be intercalated with ':' (ex. N:c:m:s:n:n).++# [attribute] <- means attribute is optional (ex. Md - numeral tag)+# number 9 represents the '-' (dash)++# attributes in need of a 9:+# person, number, gender, number1, gender1, pclitic, preferenttype++# f <- read `fmap` readFile "full-dictionary.txt" :: IO (M.Map String (S.Set String))+# let train = S.toList . S.fromList . concat . map (S.toList snd) $ M.toList f+# let f = S.fromList . concat . map (L.findIndices (=='-')) .  filter (elem '-')+# zip poss $ map f . map (\x -> filter ((==x).head) train) $ poss++# appereance of '-' in the corpus (unknown parameter)+# ('N',[gender])+# ('V',[person,gender])+# ('A',[])+# ('P',[person,gender,number,number1,gender1,pclitic,preferenttype])+# ('R',[])+# ('S',[])+# ('C',[])+# ('M',[gender])+# ('Q',[])+# ('Y',[])+# ('X',[])+# ('Z',[])++# appereance of '-' in construction for MA+# ('N',fromList [])+# ('V',fromList [person,gender])+# ('A',fromList [adefiniteness])+# ('P',fromList [person,gender,number,number1,gender1,preferenttype]) -- !!! source of eval errors+# ('R',fromList [])+# ('S',fromList [])+# ('C',fromList [])+# ('M',fromList [gender])+# ('Q',fromList [])+# ('Y',fromList [])+# ('X',fromList [])+# ('Z',fromList [])+++[ATTR]++# Attributes which appear in MSDs follow.++# Global attributes++case = n g d a v l i+gender = m f n 9+animate = n y+number = s p 9+person = 1 2 3 9+degree = p c s++number1 = s p 9+gender1 = m f n 9++# Noun attributes (N)++ntype    = c p++# Verb attributes (V)++vtype     = m a c+vform     = n p r f m a e+vnegative = n y++# Adjective attributes (A)++atype         = g s p+adefiniteness = n y 9++# Pronoun attributes (P)++ptype          = p d i s q r x+pclitic        = n y 9+preferenttype  = p s 9+psyntactictype = n a++# Adverb attributes (R)++rtype   = g r++# Adposition attributes (S)++# scase = g d a l i++# Conjunction attributes (C)++ctype      = c s+cformation = s c++# Numeral attributes (M)++mform    = d r l+mtype    = c o m s+++# Particle attributes (Q)++qtype = z q o r++# Interjection attributes (I)++# none++# Abbreviation attributes (Y)++# none++# Residual attributes (X)++xtype = f t p++# Special characters attributes (Z)++# none++[RULE]++# Parsing rules definitions.++N = ntype gender number case [animate]+V = vtype vform [person] [number] [gender] [vnegative]+A = atype degree gender number case [adefiniteness] [animate]+P = ptype person gender number case number1 gender1 pclitic preferenttype psyntactictype [animate]+R = rtype [degree]+S = case+C = ctype [cformation]+M = mform [mtype] [gender] [number] [case] [animate]+Q = qtype+I =+Y =+X = [xtype]+Z =
+ src/NLP/Concraft/Croatian.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+++module NLP.Concraft.Croatian+(+-- * Model+  C.Concraft+, C.saveModel+, C.loadModel++-- * Tagging+, tag+, marginals++-- * Training+, TrainConf (..)+, train++-- * Pruning+, C.prune++) where+++import qualified Data.Set as S+import qualified Data.Map as M++import qualified Data.Tagset.Positional as P+import qualified Numeric.SGD as SGD++import qualified NLP.Concraft.Morphosyntax as X+import qualified NLP.Concraft.Schema as S+import           NLP.Concraft.Schema (SchemaConf(..), entry, entryWith)+import qualified NLP.Concraft.Guess as G+import qualified NLP.Concraft.Disamb as D+import qualified NLP.Concraft as C++import           NLP.Concraft.Croatian.Morphosyntax+++-------------------------------------------------+-- Default configuration+-------------------------------------------------+++-- | Default configuration for the guessing observation schema. This configuration+-- serves as a definition for the feature function creation of the conditional random+-- fields model that guesses a set of possible tags for unknown words. Unknown words+-- do not have a set of possible tags before the tagging procedure (analyzer didn't+-- output a single possible tag).+guessSchemaDefault :: SchemaConf+guessSchemaDefault = S.nullConf -- TODO make this configurable from the real world+    { lowPrefixesC  = entryWith [1, 2]      [0]+    , lowSuffixesC  = entryWith [1, 2]      [0]+    , knownC        = entry                 [0]+    , begPackedC    = entry                 [0] }+++-- | Default configuration for the guessing observation schema. This configuration+-- serves as a definition for the feature function creation of the conditional random+-- fields model that disambiguates the correct tag from the set of possible ones.+disambSchemaDefault :: SchemaConf+disambSchemaDefault = S.nullConf -- TODO make this configurable from the real world+    { lowOrthC      = entry                         [-2, -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 { S.oovOnly = True }+    oov Nothing     = Nothing+++-- | Default tiered tagging configuration. This configuration serves as a+-- definition for the feature function creation of the conditional random+-- fields model.+tiersDefault :: [D.Tier]+tiersDefault = -- TODO make this configurable from the real world+    [tier1+    ,tier2+    ,tier3+    ]+  where+    tier1 = D.Tier True  $ S.fromList ["ntype","vtype","atype","ptype","rtype","ctype","mtype","qtype","xtype"]+    tier2 = D.Tier False $ S.fromList ["scase", "case","gender","animate"]+    tier3 = D.Tier False $ S.fromList+      ["cformation", "mform", "pclitic","person","person1",+       "preferenttype", "psyntactictype","adefiniteness",+       "vform","vnegative", "number", "number1","degree"]+++-------------------------------------------------+-- Tagging+-------------------------------------------------+++-- | Tag the analysed sentence. it is expected that+-- the result of the tagging is a list of tuples @(a,b)@ the+-- set of possible tags (which were guessed by the guessing model or+-- as a result of analysis from the 'Analyzer') @a@, and the disambiguated+-- tag @b@.+tag :: C.Concraft -> X.Sent Word P.Tag -> [(S.Set P.Tag, P.Tag)]+tag = C.tag+++-- | Tag the sentence with marginal probabilities. The resulting sentence+-- contains the probabilites of each tag given in the set.+marginals :: C.Concraft -> X.Sent Word P.Tag -> X.Sent Word P.Tag+marginals concraft sent = addMarginals sent wmaps+  where wmaps = C.marginals concraft sent++-- | Adds the tags recevied by the 'marginals' tagging function.+-- Marginal probabilites of each tag are added+-- (or modified if there was any data previously).+addMarginals :: X.Sent Word P.Tag  -- ^ Sentence of words that can contain tags for each word.+             -> [X.WMap P.Tag]     -- ^ Map of tags as keys to their marginal probabilities.+             -> X.Sent Word P.Tag  -- ^ Sentence with additional or modified tags (probabilities get changed)+addMarginals = zipWith f+    where f seg tgs  = seg { X.tags = X.mkWMap $ M.toList unionWP} -- TODO inefficient but hidden in mkWMap+            where wtagsMap = X.unWMap tgs            -- weighted analysis tags+                  ptagsMap = X.unWMap . X.tags $ seg -- previous tags+                  unionWP  = M.unionWith (flip const) ptagsMap wtagsMap -- if tag exists keep analysis+-------------------------------------------------+-- Training+-------------------------------------------------+++-- | Training configuration.+data TrainConf = TrainConf {+      tagset    :: P.Tagset+    -- ^ Tagset.++    , gSgdArgs   :: SGD.SgdArgs+    -- ^ SGD parameters for the guessing model.++    , dSgdArgs   :: SGD.SgdArgs+    -- ^ SGD parameters for the disambiguation model.++    , reana     :: Bool+    -- ^ Perform reanalysis.++    , onDisk    :: Bool+    -- ^ Store SGD dataset on disk.++    , guessNum  :: Int+    -- ^ Number of guessed tags for each word. The guessing model will+    -- output the possible tags with their probabilities. The first 'guessNum',+    -- sorted in the descending order by the probability,+    -- will form the whole set of possible tags.++    , r0        :: G.R0T+    -- ^ `G.r0T` parameter.+    }++-- | Begins the training of the model, if evaluation data is supplied, the+-- periodic report will contain an optimistic accuracy of the model.+-- Optimistic in the sense of taking the given correct tag and set of+-- possible tags as the complete results of the analysis. It is possible that the+-- morphosyntactic analyzer used to provide the set of possible tags doesn't+-- include the correct tag in the set. Hence, the optimistic accuracy report.+train+    :: TrainConf                   -- ^ Training configuration+    -> IO [X.Sent Word P.Tag]      -- ^ Training data+    -> IO [X.Sent Word P.Tag]      -- ^ Evaluation data+    -> IO C.Concraft               -- ^ Trained model+train TrainConf{..} = C.train tagset guessNum guessConf disambConf+  where+    guessConf  = G.TrainConf guessSchemaDefault gSgdArgs onDisk r0+    disambConf = D.TrainConf tiersDefault disambSchemaDefault dSgdArgs onDisk
+ src/NLP/Concraft/Croatian/Morphosyntax.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Morphosyntax data layer in Croatian.+module NLP.Concraft.Croatian.Morphosyntax+(+  packSent+, packSentT+, addAnalysis+, extractSentences+, transformToConfig+, Word(..)+, ListLike(..)+) where++import           Data.Aeson (FromJSON, ToJSON)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Tagset.Positional as P+import           GHC.Generics+import           Data.String (IsString)+import           Data.Binary (Binary(..))+import qualified NLP.Concraft.Morphosyntax as X+import           NLP.Concraft.Morphosyntax (Seg(..)) -- for easier handling of Seg+import qualified Data.Map as M+import qualified Data.Set as S++-- | Representation of a word.+data Word = Word {+    orth :: T.Text -- ^ Orthographic (plainly normal) form.+  , oov :: Bool    -- ^ Indicates whether a word is out-of-dictionary or not.+                   -- It is assumed that the word is out-of-dictionary if no+                   -- tags were provided for the word. If additional analysis+                   -- gives a non-empty set of possible tags this value should+                   -- (and is in this tagger) change the value accordingly.+  }+    deriving (Show,Generic, Eq, Ord)++-- | Instance needed for the use of the concraft model.+instance X.Word Word where+    orth = orth+    oov  = oov++instance Binary Word   -- Needed for the Client-Server communication.+instance FromJSON Word -- Needed for the concraft model.+instance ToJSON Word   -- Needed for the concraft model.++-- | Orphan instance needed for Client-Server communcation.+-- Used primarily in 'NLP.Concraft.Croatian.Request'.+-- Could be moved to concraft library.+instance (Binary a, Binary b) => Binary (Seg a b) where+    put (Seg x ts) = put x >> put ts+    get = do+        x <- get+        y <- get+        return $ Seg x y++-- | Used to allow use of same functions on lazy and strict+-- inputs. It is assumed that the function behave as they do+-- in 'T.Text', 'L.Text' or 'String' modules.+class (Data.String.IsString a) => ListLike a where+    tcintersperse :: Char -> a -> a+    tcmap :: (Char -> Char) -> a -> a+    strict :: a -> T.Text+    tcwords :: a -> [a]+    tcsplitOn :: a -> a -> [a]+    tcnull :: a -> Bool+    tclines :: a -> [a]++instance ListLike T.Text where+    tcintersperse = T.intersperse+    tcmap = T.map+    strict = id+    tcwords = T.words+    tcsplitOn = T.splitOn+    tcnull = T.null+    tclines = T.lines++instance ListLike L.Text where+    tcintersperse = L.intersperse+    tcmap = L.map+    strict = L.toStrict+    tcwords = L.words+    tcsplitOn = L.splitOn+    tcnull = L.null+    tclines = L.lines++-- | Transforms a given string to a model suited string.+-- Ex. Nsmnn -> N:s:m:n:n, or Vmp-sf -> V:m:p:9:s:f, all+-- '-' to '9'.+transformToConfig :: ListLike a => a -> a+transformToConfig = tcintersperse ':' . tcmap toNine+  where toNine x = if x `elem` "=-" then '9' else x++-- | Given a sentence and a list of tags for each word this function adds+-- the tags.+addAnalysis :: X.Sent Word P.Tag -> [S.Set P.Tag] -> X.Sent Word P.Tag+addAnalysis = zipWith f+    where f seg tgs = seg { word = (word seg) { oov = M.null unionWP } -- out-of-dictionary if no analysis+                          , tags = X.mkWMap . M.toList $ unionWP}      -- TODO inefficient+            where wtagsMap = M.fromList $ zip (S.toList tgs) [0,0..]   -- weighted analysis tags+                  ptagsMap = X.unWMap . tags $ seg                     -- previous tags+                  unionWP  = M.unionWith const ptagsMap wtagsMap       -- if tag exists discard the analysis++-- | Given a tagset and a list of words it packs them into+-- 'X.Sent' data from, used by the tagging model. It is assumedd+-- that all of the tags do not have any prior probabilites. If+-- this was used on the training set the function wouldn't differentiate+-- correct from possible tags.+packSent :: ListLike a => P.Tagset -> [a] -> X.Sent Word P.Tag+packSent = packSentP [0.0,0.0..]++-- | Packs the training data to sentences with the first tag having+-- the highest probability. Suitable for using on the training set.+packSentT :: ListLike a => P.Tagset -> [a] -> X.Sent Word P.Tag+packSentT = packSentP $ 1.0 : [0.0,0.0..]++-- | Line number saver.+packSentP :: ListLike a => [Double] -> P.Tagset -> [a] -> X.Sent Word P.Tag+packSentP dist tset = map (packSegP tset dist)++-- | Given a string, a tagset returns a segment with+-- possible tags having the default double weight. TODO For language-agnostic+-- use the dependency 'transformToConfig' should be removed and a proper+-- parser for 'P.Tagset' and 'P.Tag' should be written.+packSegP :: ListLike a => P.Tagset -> [Double] -> a -> X.Seg Word P.Tag+packSegP tset dist xs = X.Seg {word=mywrd, tags=wmap}+  where (w:tagxs) = tcwords xs+        wmap      = X.mkWMap $ zip rtags dist+        rtags     = map (P.parseTag tset . strict . transformToConfig) tagxs+        mywrd     = Word {orth=strict w, oov=null rtags}++-- | Extracts sentences from a given input. Rarely used since it's+-- not always the case that we can assume the sentences are separated+-- only by two newline characters.+extractSentences :: ListLike a => a -> [[a]]+extractSentences =+    map tclines . filter (not . tcnull) . tcsplitOn "\n\n"
+ src/NLP/Concraft/Croatian/Request.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE RecordWildCards #-}++module NLP.Concraft.Croatian.Request+(+-- * Request+  Request (..)+-- ** Short+, TagWork (..)+, short+) where+++import           Control.Applicative ((<$>))+import qualified Data.Binary as B++import           NLP.Concraft.Croatian+import           NLP.Concraft.Croatian.Morphosyntax+import           NLP.Concraft.Morphosyntax          hiding (Word, orth)+import qualified Data.Tagset.Positional as P+import qualified Data.Set as S+import qualified Data.Text as T+import           NLP.Morphosyntax.Analyzer++-------------------------------------------------+-- Configuration+-------------------------------------------------+++-- | A request with configuration.+newtype Request t = Request {+    -- | The actual request.+      rqBody    :: t+    }+++instance B.Binary t => B.Binary (Request t)  where+    put Request{..} = B.put rqBody+    get = Request <$> B.get++++-------------------------------------------------+-- Short request+-------------------------------------------------+++-- | A type of tagging work which is requested.+data TagWork+    = Marginal [Sent Word P.Tag]+    | PlainTag [Sent Word P.Tag]+    | MarginalA [Sent Word P.Tag]+    | PlainTagA [Sent Word P.Tag]++instance B.Binary TagWork where+    put (Marginal x)  = B.putWord8 0 >> B.put x+    put (PlainTag x)  = B.putWord8 1 >> B.put x+    put (MarginalA x) = B.putWord8 2 >> B.put x+    put (PlainTagA x) = B.putWord8 3 >> B.put x+    get =+        B.getWord8 >>= \x -> case x of+            0   -> Marginal <$> B.get+            1   -> PlainTag <$> B.get+            2   -> MarginalA <$> B.get+            _   -> PlainTagA <$> B.get++-- | Process the short request with or without analysis.+short :: Analyzer         -- ^ Morphosyntactic analyzer, if analysis needs to be done.+      -> Concraft         -- ^ Trained concraft model, needed for tagging.+      -> Request TagWork  -- ^ Tagwork of sorts, be it in need of tagging with marginals or tagging with reanalysis.+      -> IO (Either [Sent Word P.Tag] [[(S.Set P.Tag, P.Tag)]])+short analyzer concraft Request{..} = do+    let anaf = getTags analyzer+    return $ case rqBody of+                Marginal x  -> Left  $ map (marginals concraft) x+                PlainTag x  -> Right $ map (tag concraft) x+                MarginalA x -> Left  $ map (marginals concraft) (addAna anaf x)+                PlainTagA x -> Right $ map (tag concraft) (addAna anaf x)++-- | Adds the analysis to the list of sentences.+addAna :: (T.Text -> S.Set P.Tag) -- analysis function+       -> [Sent Word P.Tag]       -- sentences without analyzed words+       -> [Sent Word P.Tag]       -- analysis is added+addAna ana x = zipWith addAnalysis x (map (map (ana . orth . word)) x)
+ src/NLP/Concraft/Croatian/Server.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}+++module NLP.Concraft.Croatian.Server+(+-- * Server+  runConcraftServer++-- * Client+, submit+) where+++import           Control.Applicative ((<$>))+import           Control.Monad (forever, void, mapM_)+import           Control.Concurrent (forkIO)+import           System.IO (Handle, hFlush)+import qualified Network as N+import qualified Data.Binary as B+import qualified Data.ByteString.Lazy as BS+import qualified Data.Set as S+import qualified NLP.Concraft.Morphosyntax as X+import           NLP.Concraft.Croatian.Morphosyntax+import qualified NLP.Concraft.Croatian as C+import qualified NLP.Concraft.Croatian.Request as R+import qualified Data.Tagset.Positional as P++import qualified NLP.Morphosyntax.Analyzer as A++------------------------------------------------+-- Server+-------------------------------------------------+++-- | Run a Concraft server on a given port.+runConcraftServer :: A.Analyzer -> C.Concraft -> N.PortID -> IO ()+runConcraftServer analyzer concraft port = N.withSocketsDo $ do+    sock <- N.listenOn port+    forever $ sockHandler analyzer concraft sock+++-- | Read and process short requests from the socket.+sockHandler :: A.Analyzer -> C.Concraft -> N.Socket -> IO ()+sockHandler analyzer concraft sock = do+    (handle, _, _) <- N.accept sock+    -- putStrLn "Connection established"+    void $ forkIO $ do+        -- putStrLn "Waiting for input..."+        inp <- recvMsg handle              -- TODO make things streaming, not strict+        -- putStr "> " >> T.putStrLn inp+        out <- R.short analyzer concraft inp+        -- putStr "No. of sentences: " >> print (length out)+        sendMsg handle out+++-------------------------------------------------+-- Client+-------------------------------------------------+++-- | Submit the given request.+submit :: N.HostName -> N.PortID -> R.Request R.TagWork -> IO (Either [X.Sent Word P.Tag] [[(S.Set P.Tag, P.Tag)]])+submit host port inp = do+    handle <- N.connectTo host port+    -- putStrLn "Connection established"+    -- putStr "Send request: " >> T.putStrLn inp+    sendMsg handle inp+    recvMsg handle+++-------------------------------------------------+-- Communication+-------------------------------------------------+++sendMsg :: B.Binary a => Handle -> a -> IO ()+sendMsg h msg = do+    let x = B.encode msg+        n = fromIntegral $ BS.length x+    sendInt h n+    BS.hPut h x+    hFlush h+++recvMsg :: B.Binary a => Handle -> IO a+recvMsg h = do+    n <- recvInt h+    B.decode <$> BS.hGet h n+++sendInt :: Handle -> Int -> IO ()+sendInt h x = BS.hPut h (B.encode x)+++recvInt :: Handle -> IO Int+recvInt h = B.decode <$> BS.hGet h 8
+ tools/concraft-hr.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+++import           Control.Applicative ((<$>))+import           Control.Monad (unless, forM_)++import           Data.Double.Conversion.Text (toShortest)++import           System.Console.CmdArgs+import           System.IO (hFlush, stdout)++import qualified Network as N+import qualified Numeric.SGD as SGD++import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L+import qualified Data.Text      as T+import qualified Data.Text.IO      as T+import qualified Data.List.Split as Split+import qualified Data.Char as Char+import           Data.Tagset.Positional (parseTagset)+import qualified Data.Tagset.Positional as P+import           Data.Maybe (fromMaybe)+import qualified Data.Map as M++import qualified NLP.Concraft.Morphosyntax.Accuracy as Acc+import qualified NLP.Concraft.Guess as Guess++import qualified NLP.Concraft.Croatian as C+import           NLP.Concraft (tagset)+import qualified NLP.Concraft.Croatian.Request as R+import qualified NLP.Concraft.Croatian.Server as S+import qualified NLP.Concraft.Croatian.Morphosyntax as X+import qualified NLP.Concraft.Morphosyntax as X hiding (Word, orth)++import           Paths_concraft_hr (version, getDataFileName)+import           Data.Version (showVersion)++import qualified NLP.Morphosyntax.Analyzer as A++-- | Default port number.+portDefault :: Int+portDefault = 43982+++---------------------------------------+-- Command line options+---------------------------------------++-- | A description of the Concraft-hr tool.+concraftDesc :: String+concraftDesc = "Concraft-hr " ++ showVersion version+++data Concraft+  =+    -- | Training mode. Requires a path to the training file and output file, all+    -- other arguments are optional. It is recommended that one at least tries to+    -- find a proper regularization value, otherwise it is possible that the model+    -- fits the data a lot. On Croatian dataset the fit with the default regularization+    -- value is close to 100% (not good if you want to tag something other than your+    -- training set).+    Train+    { trainPath	    :: FilePath+    , evalPath      :: Maybe FilePath+    , tagsetPath    :: Maybe FilePath+    , noAna         :: Bool+    , inAnalyzer    :: Maybe FilePath+    , gIterNum      :: Double+    , dIterNum      :: Double   -- Double?+    , gBatchSize    :: Int+    , dBatchSize    :: Int+    , gRegVar       :: Double+    , dRegVar       :: Double+    , gGain0        :: Double+    , dGain0        :: Double+    , gTau          :: Double+    , dTau          :: Double+    , disk          :: Bool+    , outModel      :: FilePath+    , guessNum      :: Int+    , r0            :: Guess.R0T }+    -- | Tagging mode. This one requires a model and all other parameters are optional.+    -- It is recommended to precompute the analysis (set of possible tags) for all words+    -- if testing/evaluating the models, otherwise the analyzer is necessary for the+    -- tagging to work.+  | Tag+    { inModel       :: FilePath+    , inAnalyzer    :: Maybe FilePath+    , noAna         :: Bool+    , marginals     :: Bool }+    -- , guessNum      :: Int }+    -- | Server mode starts the server and requires a path to the model and analyzer.+    -- It is recommended to provide a path to the analyzer as it might+    -- happen that 'Client' started requires additional analysis. If not the analyzer+    -- won't be used but currently it's necessary to provide a path.+  | Server+    { inModel       :: FilePath+    , inAnalyzer    :: Maybe FilePath+    , port          :: Int }+    -- | Client mode starts a client which communicates with the 'Server' in a type-safe+    -- manner. The results are produced to standard output on the client side.+  | Client+    { noAna         :: Bool+    , tagsetPath    :: Maybe FilePath+    , marginals     :: Bool+    , host          :: String+    , port          :: Int }+    -- | Compare mode can be used to produce accuracy results for the two provided+    -- tagged sentences in files.+  | Compare+    { tagsetPath    :: Maybe FilePath+    , refPath       :: FilePath+    , otherPath     :: FilePath+    }+    -- | Prune mode given a path to the model, output model, and threshold value removes+    -- the features from the tagging model which have weights below the threshold (in log-domain).+  | Prune+    { inModel       :: FilePath+    , outModel      :: FilePath+    , threshold     :: Double }+--   | ReAna+--     { format	    :: Format }+  deriving (Data, Typeable, Show)+++trainMode :: Concraft+trainMode = Train+    { trainPath = def &= argPos 1 &= typ "TRAIN-FILE"+    , evalPath = def &= typFile &= help "Evaluation file"+    , tagsetPath = def &= typFile &= help "Tagset definition file"+    , noAna = False &= help "Do not perform reanalysis - (False)"+    , inAnalyzer= def &= typFile &= help "Morphosyntactic analyzer - needed if noana is false"+    -- , discardHidden = False &= help "Discard hidden features"+    , gIterNum = 20 &= help "Number of SGD iterations of guessing model - (20)"+    , dIterNum = 20 &= help "Number of SGD iterations of disambiguation model - (20)"+    , gBatchSize = 50 &= help "Batch size for SGD of guessing model - (50)"+    , dBatchSize = 50 &= help "Batch size for SGD of disambiguation model - (50)"+    , gRegVar = 10.0 &= help "Regularization variance of guessing model - (10.0)"+    , dRegVar = 10.0 &= help "Regularization variance of disambiguation model - (10.0)"+    , gGain0 = 1.0 &= help "Initial gain parameter of guessing model - (1.0)"+    , dGain0 = 1.0 &= help "Initial gain parameter of disambiguation model - (1.0)"+    , gTau = 5.0 &= help "Initial tau parameter of guessing model - (5.0)"+    , dTau = 5.0 &= help "Initial tau parameter for disambiguation model - (5.0)"+    , disk = False &= help "Store SGD dataset on disk - (False)"+    , outModel = def &= typFile &= help "Output Model file"+    , guessNum = 10 &= help "Number of guessed tags for each unknown word - (10)"+    , r0 = Guess.OovChosen &= help "R0 construction method (AnyInterps, AnyChosen, OovChosen) - (OovChosen)" }+     &= help "Training mode - needs training data - outputs a CRF model to a given filepath.\+                \ Values or modes shown between the brackets are default values."+++tagMode :: Concraft+tagMode = Tag+    { inModel   = def &= argPos 0 &= typ "MODEL-FILE"+    , inAnalyzer= def &= typFile &= help "Morphosyntactic analyzer - needed if noana is false"+    , noAna     = False &= help "Do not analyse input text - (False)"+    , marginals = False &= help "Tag with marginal probabilities - (False)" }+    -- , guessNum = 10 &= help "Number of guessed tags for each unknown word" }+    &= help "Given tokenized input data it outputs the same tokenized form with tags next to each word.\+                \ Values shown between the brackets are default values."++serverMode :: Concraft+serverMode = Server+    { inModel = def &= argPos 0 &= typ "MODEL-FILE" &= help "Concraft model file"+    , inAnalyzer= def &= typFile &= help "Morphosyntactic analyzer file"+    , port    = portDefault &= help "Port number" }+    &= help "Starts a server which can process requests of tokenized sentences - tagging and analysis."+++clientMode :: Concraft+clientMode = Client+    { noAna   = False &= help "Do not perform reanalysis"+    , tagsetPath = def &= typFile &= help "Tagset definition file"+    , port    = portDefault &= help "Port number - (43982)"+    , host    = "localhost" &= help "Server host name"+    , marginals = False &= help "Tag with marginal probabilities" }+    &= help "Starts a client which sends requests of tokenized sentences, received from stdin, to server."+++compareMode :: Concraft+compareMode = Compare+    { refPath   = def &= argPos 1 &= typ "REFERENCE-FILE"+    , otherPath = def &= argPos 2 &= typ "OTHER-FILE"+    , tagsetPath = def &= typFile &= help "Tagset definition file"+    }+    &= help "Compares the two given files -- meant to be used for accuracy checking of the model."+++pruneMode :: Concraft+pruneMode = Prune+    { inModel   = def &= argPos 0 &= typ "INPUT-MODEL"+    , outModel  = def &= argPos 1 &= typ "OUTPUT-MODEL"+    , threshold = 0.05 &=+        help "Remove disambiguation features below the threshold - (0.05)" }+    &= help "Prunes (removes) the features of the model (in log-domain) with weights below the given threshold."++argModes :: Mode (CmdArgs Concraft)+argModes = cmdArgsMode $ modes+    [trainMode, tagMode, serverMode, clientMode, compareMode, pruneMode]+    &= summary concraftDesc+    &= program "concraft-hr"+++---------------------------------------+-- Main+---------------------------------------+++main :: IO ()+main = exec =<< cmdArgsRun argModes+++exec :: Concraft -> IO ()+++exec Train{..} = do+    tagsetPath' <- case tagsetPath of+        Nothing -> getDataFileName "config/tagset.cfg"+        Just x  -> return x+    tset <- parseTagset tagsetPath' <$> readFile tagsetPath'+    let train0 = parseTrain tset trainPath+    let eval0  = case evalPath of+            Nothing -> return []+            Just x  -> parseTrain tset x+    let alyzer = fmap A.load inAnalyzer+    analyzer <- fromMaybe (if noAna then undefined else error errMsg) alyzer+    let af = analyze $ A.getTags analyzer -- analysis function+    let train1 = if noAna then train0 else map af <$> train0+    let eval1  = if noAna then eval0  else map af <$> eval0++    concraft <- C.train (trainConf tset) train1 eval1+    unless (null outModel) $ do+        putStrLn $ "\nSaving model in " ++ outModel ++ "..."+        C.saveModel outModel concraft+  where+    analyze af sent = X.addAnalysis sent (map (af . X.orth . X.word) sent)+    gsgdArgs = SGD.SgdArgs+        { SGD.batchSize = gBatchSize+        , SGD.regVar = gRegVar+        , SGD.iterNum = gIterNum+        , SGD.gain0 = gGain0+        , SGD.tau = gTau }+    dsgdArgs = SGD.SgdArgs+        { SGD.batchSize = dBatchSize+        , SGD.regVar = dRegVar+        , SGD.iterNum = dIterNum+        , SGD.gain0 = dGain0+        , SGD.tau = dTau }+    trainConf tagset = C.TrainConf+        { tagset    = tagset+        , gSgdArgs  = gsgdArgs+        , dSgdArgs  = dsgdArgs+        , reana     = not noAna+        , onDisk    = disk+        , guessNum  = guessNum+        , r0        = r0 }+    errMsg = "Please define the path to analyzer or set -noana to true!\n"++exec Tag{..} = do+    cft    <- C.loadModel inModel+    let alyzer = fmap A.load inAnalyzer+    analyzer <- fromMaybe (if noAna then undefined else error errMsg) alyzer+    let tset = tagset cft+    inp <- parseContent tset <$> L.getContents+    out <- R.short analyzer cft $ rq $ buildReq inp+    showData tset $ fmap (addTags inp) out+  where+    -- | The @x@ is sentence of words and possible interpretations.+    -- If the chosen tagging mod isn't marginals, it is expected that+    -- the result of the tagging is a list of tuples @(a,b)@ the+    -- set of possible tags (which were guessed by the guessing model or+    -- as a result of analysis from the 'Analyzer') @a@, and the disambiguated+    -- tag @b@. The 'X.Seg' is then zipped with a tag to prepare the results+    -- for the output.+    addTags x = zip x . map (map snd)+    -- | Builds a request and adds the body which will be sent to the server.+    rq x = R.Request { R.rqBody = x }+    errMsg = "Please define the path to analyzer or set -noana to true!\n"+    -- | Depending on the no-analysis and marginals boolean values a proper+    -- constructor is chosen. Constructors having an A suffix obviously are+    -- used to indicate that additional analysis is needed.+    buildReq =+        case (noAna, marginals) of+            (True,True)  -> R.Marginal+            (True,False) -> R.PlainTag+            (False,True) -> R.MarginalA+            (False,False)-> R.PlainTagA++exec Server{..} = do+    putStr "Loading model..." >> hFlush stdout+    concraft <- C.loadModel inModel+    putStr "Loading analyzer..." >> hFlush stdout+    let alyzer = fmap A.load inAnalyzer+    analyzer <- fromMaybe (error errMsg) alyzer+    putStrLn " done"+    let portNum = N.PortNumber $ fromIntegral port+    putStrLn $ "Listening on port " ++ show port+    S.runConcraftServer analyzer concraft portNum+    where+        errMsg = "Please define the path to analyzer!\n"++exec Client{..} = do+    tagsetPath' <- case tagsetPath of+        Nothing -> getDataFileName "config/tagset.cfg"+        Just x  -> return x+    tset <- parseTagset tagsetPath' <$> readFile tagsetPath'+    let portNum = N.PortNumber $ fromIntegral port+    inp <- parseContent tset <$> L.getContents+    out <- S.submit host portNum $ rq $ buildReq inp++    showData tset (fmap (addTags inp) out)+  where+    -- | The @x@ is sentence of words and possible interpretations.+    -- If the chosen tagging mod isn't marginals, it is expected that+    -- the result of the tagging is a list of tuples @(a,b)@ the+    -- set of possible tags (which were guessed by the guessing model or+    -- as a result of analysis from the 'Analyzer') @a@, and the disambiguated+    -- tag @b@. The 'X.Seg' is then zipped with a tag to prepare the results+    -- for the output.+    addTags x = zip x . map (map snd)+    -- | Builds a request and adds the body which will be sent to the server.+    rq x = R.Request+        { R.rqBody = x}+    -- | Depending on the no-analysis and marginals boolean values a proper+    -- constructor is chosen. Constructors having an A suffix obviously are+    -- used to indicate that additional analysis is needed.+    buildReq =+        case (noAna, marginals) of+            (True,True)  -> R.Marginal+            (True,False) -> R.PlainTag+            (False,True) -> R.MarginalA+            (False,False)-> R.PlainTagA++exec Compare{..} = do+    tagsetPath' <- case tagsetPath of+        Nothing -> getDataFileName "config/tagset.cfg" -- if no path is given the default one is used+        Just x  -> return x+    tset <- parseTagset tagsetPath' <$> readFile tagsetPath'+    let convert = concat+    xs <- convert <$> parseFile tset refPath+    ys <- convert <$> parseFile tset otherPath+    let s = Acc.weakLB tset xs ys+    putStrLn $ "Number of segments in reference file: " ++ show (Acc.gold s)+    putStrLn $ "Number of correct tags: " ++ show (Acc.good s)+    putStrLn $ "Weak accuracy lower bound: " ++ show (Acc.accuracy s)+++exec Prune{..} = do+    cft <- C.loadModel inModel+    C.saveModel outModel $ C.prune threshold cft++---------------------------------------+-- Reading files+---------------------------------------++parseFileG :: ([L.Text] -> X.Sent X.Word P.Tag)+           -> FilePath+           -> IO [X.Sent X.Word P.Tag]+parseFileG packSent path =+    map packSent . parseText <$> L.readFile path++-- | Assumes that the given 'FilePath' is a file containing the training set.+-- It is also assumed that the sentences in the file are clearly separated by+-- at least two whitespaces (be it newlines or spaces) and that each word is+-- in its own row and any tags should follow the word (in the same row) separated+-- by one or more whitespaces.+parseTrain :: P.Tagset -> FilePath -> IO [X.Sent X.Word P.Tag]+parseTrain tset = parseFileG (X.packSentT tset)++-- | It is assumed that the sentences in the file are clearly separated by+-- at least two whitespaces (be it newlines or spaces) and that each word is+-- in its own row and any tags should follow the word (in the same row) separated+-- by one or more whitespaces.+parseFile :: P.Tagset -> FilePath -> IO [X.Sent X.Word P.Tag]+parseFile tset = parseFileG (X.packSent tset)+++---------------------------------------+-- Parsing+---------------------------------------++-- | Parses a given 'L.Text'. Function is used to prepare the data for packing+-- into 'X.Sent'. Used by 'parseFile' and 'parseTrain'.+parseText :: L.Text -> [[L.Text]]+parseText = filter (not . null) . Split.splitWhen (L.all Char.isSpace) . L.lines++-- | Used as a function which parses the formated input as described in 'parseTrain' or+-- 'parseFile' but doesn't except a 'FilePath'.+parseContent :: P.Tagset -> L.Text -> [X.Sent X.Word P.Tag]+parseContent tset = map (X.packSent tset) . parseText++---------------------------------------+-- Displaying data+---------------------------------------++-- | Displays the data of tagged sentences.+-- If tagging was done using marginal probabilities all the tags are shown+-- with their corresponding probabilities - format WORD(\tPROB\tTAG)+\n.+-- Otherwise, WORD\tTAG\n format is used and sentences are separated with a newline character.+showData :: P.Tagset+         -> Either [X.Sent X.Word P.Tag] [(X.Sent X.Word P.Tag, [P.Tag])]+         -> IO ()+showData tset (Left xss) =+    forM_ xss (\sentence -> do+        forM_ sentence (\wrd -> do+            T.putStr $ (X.orth . X.word) wrd+            forM_ (M.toList . X.unWMap $ X.tags wrd) (\(tg,prob) -> do+                T.putStr "\t"+                T.putStr $ toShortest prob+                T.putStr "\t"+                T.putStr . T.filter (/=':') . P.showTag tset $ tg+                -- ^^ Text form of a tag is filtered because by default+                -- the separator between POS and attributes is ':'+                -- TODO remove the dependency on the 'P.showTag'+                )+            T.putStr "\n"+            )+        T.putStr "\n"+        )+showData tset (Right xss) =+    forM_ xss (\(sent, tgs) -> do+        forM_ (zip sent tgs) (\(wrd, tg) -> do+            T.putStr $ (X.orth . X.word) wrd+            T.putStr "\t"+            T.putStr . T.filter (/=':') . P.showTag tset $ tg+            T.putStr "\n"+            )+        T.putStr "\n"+    )