diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/concraft-hr.cabal b/concraft-hr.cabal new file mode 100644 --- /dev/null +++ b/concraft-hr.cabal @@ -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 diff --git a/config/tagset.cfg b/config/tagset.cfg new file mode 100644 --- /dev/null +++ b/config/tagset.cfg @@ -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 = diff --git a/src/NLP/Concraft/Croatian.hs b/src/NLP/Concraft/Croatian.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Croatian.hs @@ -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 diff --git a/src/NLP/Concraft/Croatian/Morphosyntax.hs b/src/NLP/Concraft/Croatian/Morphosyntax.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Croatian/Morphosyntax.hs @@ -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" diff --git a/src/NLP/Concraft/Croatian/Request.hs b/src/NLP/Concraft/Croatian/Request.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Croatian/Request.hs @@ -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) diff --git a/src/NLP/Concraft/Croatian/Server.hs b/src/NLP/Concraft/Croatian/Server.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Croatian/Server.hs @@ -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 diff --git a/tools/concraft-hr.hs b/tools/concraft-hr.hs new file mode 100644 --- /dev/null +++ b/tools/concraft-hr.hs @@ -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" + )