diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,16 +1,30 @@ -# NGrams +# NGram This is a code base for experimenting with various approaches to n-gram-based -text modeling. To get started, run: +text modeling. -```bash +## Compiling + +First install [Stack](https://docs.haskellstack.org) somewhere on your `PATH`. For example, for `~/.local/bin`: + +``` +wget https://get.haskellstack.org/stable/linux-x86_64.tar.gz -O -|tar xpfz - -C /tmp +cp /tmp/stack-*/stack ~/.local/bin +rm -rf /tmp/stack-* +``` + +Then, while in the directory of this README file, run: + +``` stack build -stack install ``` -This will build and install the library and binary commands. Generally, -the commands expect data to be text files where each line has the format: +The first time this runs will take a while, 10 or 15 minutes, as it builds an entire Haskell environment from scratch. Subsequent compilations are very fast. +## Running + +Generally, the commands expect data to be text files where each line has the format: + ``` ${id}${label}${text} ``` @@ -43,14 +57,14 @@ tends to outperform them on short documents. To create a PPM model, run: ```bash -sh> ppm train --train train.txt --dev dev.txt --n 4 --modelFile model.gz +sh> stack exec -- ngramClassifier train --train train.txt --dev dev.txt --n 4 --modelFile model.gz Dev accuracy: 0.8566666666666667 ``` The model can then be applied to new data: ```bash -sh> ppm apply --test test.txt --modelFile model.gz --n 4 --scoresFile scores.txt +sh> stack exec -- ngramClassifier apply --test test.txt --modelFile model.gz --n 4 --scoresFile scores.txt ``` The value of `--n` can also be less than the model size, which will run a bit diff --git a/app/NGramClassifier.hs b/app/NGramClassifier.hs new file mode 100644 --- /dev/null +++ b/app/NGramClassifier.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ExplicitNamespaces #-} + +module Main where + +import Prelude hiding (lookup) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString as BSS +import qualified Data.Maybe as M +import qualified Data.List as L +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T +import qualified Data.Text.Lazy.Encoding as T +import Codec.Compression.GZip (compress, decompress) +import Options.Generic (Generic, ParseRecord, Unwrapped, Wrapped, unwrapRecord, (:::), type ()(..)) +import Control.Monad (join, liftM) +import qualified Data.Map as Map +import System.IO (withFile, hPutStr, IOMode(..)) +import Codec.Compression.PPM (fromSequences, Model, classifySequence, scoreSequence) +import Codec.Compression.PPM.Utils (lineToInstance, accuracy, microFScore, macroFScore) +import Data.Serialize (encodeLazy, decodeLazy) +import Data.Serialize.Text + +data Parameters w = Train { train :: w ::: String "Train file" + , dev :: w ::: String "Development file" + , n :: w ::: Int "Maximum context size" + , modelFile :: w ::: String "Model file (output or input, depending on whether training or testing, respectively)" + } + | Apply { modelFile :: w ::: String "Model file (output or input, depending on whether training or testing, respectively)" + , n :: w ::: Int "Maximum context size" + , test :: w ::: String "Test file" + , scoresFile :: w ::: String "Output file for scores" + } + deriving (Generic) + +instance ParseRecord (Parameters Wrapped) +deriving instance Show (Parameters Unwrapped) + +evaluateModel :: Model T.Text Char -> Int -> [(T.Text, [Char])] -> Double +evaluateModel model n xs = accuracy golds guesses + where + golds = map fst xs + guesses = map (classifySequence model n . snd) xs + +main :: IO () +main = do + ps <- unwrapRecord "Do PPM-related stuff: all inputs should be tab-separated lines of the form IDLABELTEXT Specify a subcommand with '--help' to see its options." + case ps of + Train {..} -> do + trainInstances <- map lineToInstance <$> (liftM T.lines . liftM T.strip . T.readFile) train + let model = fromSequences n trainInstances + devInstances <- map lineToInstance <$> (liftM T.lines . liftM T.strip . T.readFile) dev + print $ evaluateModel model n devInstances + withFile modelFile WriteMode (\ h -> BS.hPutStr h ((compress . encodeLazy) model)) + Apply {..} -> do + testInstances <- map lineToInstance <$> (liftM T.lines . liftM T.strip . T.readFile) test + loader <- (decodeLazy . decompress) <$> BS.readFile modelFile :: IO (Either String (Model T.Text Char)) + case loader of + Right model -> print $ evaluateModel model n testInstances + Left error -> print error diff --git a/app/PPMClassifier.hs b/app/PPMClassifier.hs deleted file mode 100644 --- a/app/PPMClassifier.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ExplicitNamespaces #-} - -module Main where - -import Prelude hiding (lookup) -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString as BSS -import qualified Data.Maybe as M -import qualified Data.List as L -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T -import qualified Data.Text.Lazy.Encoding as T -import Codec.Compression.GZip (compress, decompress) -import Options.Generic (Generic, ParseRecord, Unwrapped, Wrapped, unwrapRecord, (:::), type ()(..)) -import Control.Monad (join, liftM) -import qualified Data.Map as Map -import System.IO (withFile, hPutStr, IOMode(..)) -import Codec.Compression.PPM (fromSequences, Model, classifySequence, scoreSequence) -import Codec.Compression.PPM.Utils (lineToInstance) -import Data.Serialize (encodeLazy, decodeLazy) -import Data.Serialize.Text - -data Parameters w = Train { train :: w ::: String "Train file" - , dev :: w ::: String "Development file (mutually exclusive with --n, which takes precendence)" - , n :: w ::: Int "Maximum context size (mutually exclusive with --dev, this option takes precedence)" - , modelFile :: w ::: String "Model file (output or input, depending on whether training or testing, respectively)" - } - | Apply { modelFile :: w ::: String "Model file (output or input, depending on whether training or testing, respectively)" - , n :: w ::: Int "Maximum context size (mutually exclusive with --dev, this option takes precedence)" - , test :: w ::: String "Test file" - , scoresFile :: w ::: String "Output file for scores" - } - deriving (Generic) - -instance ParseRecord (Parameters Wrapped) -deriving instance Show (Parameters Unwrapped) - -evaluateModel :: Model T.Text Char -> Int -> [(T.Text, [Char])] -> Double -evaluateModel m n xs = accuracy - where - gold = map fst xs - guess = map (classifySequence m n) (map snd xs) - correct = length $ [x | (x, y) <- zip gold guess, x == y] - accuracy = (fromIntegral correct) / (fromIntegral $ length gold) - - -main :: IO () -main = do - ps <- unwrapRecord "Do PPM-related stuff: all inputs should be tab-separated lines of the form IDLABELTEXT Specify a subcommand with '--help' to see its options." - case ps of - Train {..} -> do - trainInstances <- map lineToInstance <$> (liftM T.lines . liftM T.strip . T.readFile) train - let model = fromSequences n trainInstances - devInstances <- map lineToInstance <$> (liftM T.lines . liftM T.strip . T.readFile) dev - print $ evaluateModel model n devInstances - withFile modelFile WriteMode (\ h -> BS.hPutStr h ((compress . encodeLazy) model)) - Apply {..} -> do - testInstances <- map lineToInstance <$> (liftM T.lines . liftM T.strip . T.readFile) test - loader <- (decodeLazy . decompress) <$> BS.readFile modelFile :: IO (Either String (Model T.Text Char)) - case loader of - Right model -> print $ evaluateModel model n testInstances - Left error -> print error - - diff --git a/ngram.cabal b/ngram.cabal --- a/ngram.cabal +++ b/ngram.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: af4ceddbe5e5c69c25bcb8f6b1751761dbfff6d66511ba80f8b6cde5cba29c91 +-- hash: 1aef9b38a31cf7e0b80ac476b1679088314bbb55e0168d149928c083323d151c name: ngram -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Ngram models for compressing and classifying text. description: A library and collection of commands for training, evaluating, and applying n-gram-based sequence models. category: natural-language-processing, machine-learning @@ -35,6 +35,7 @@ Paths_ngram hs-source-dirs: src + default-extensions: Strict StrictData build-depends: base >=4.7 && <5 , cereal >=0.5.4.0 @@ -43,12 +44,13 @@ , text >=1.2.2 default-language: Haskell2010 -executable ppm - main-is: PPMClassifier.hs +executable ngramClassifier + main-is: NGramClassifier.hs other-modules: Paths_ngram hs-source-dirs: app + default-extensions: Strict StrictData ghc-options: -threaded -rtsopts build-depends: base >=4.7 && <5 diff --git a/src/Codec/Compression/PPM.hs b/src/Codec/Compression/PPM.hs --- a/src/Codec/Compression/PPM.hs +++ b/src/Codec/Compression/PPM.hs @@ -40,12 +40,14 @@ type Model l a = Trie (Entry a) (Map l Integer) + classifySequence :: (Ord l, Ord a, Show l, Show a) => Trie (Entry a) (Map l Integer) -> Int -> [a] -> l classifySequence m n xs = label where scores = Map.toList $ scoreSequence m n xs label = fst $ maximumBy (\(_, x) (_, y) -> compare x y) scores + scoreSequence :: (Ord l, Ord a, Show l, Show a) => Trie (Entry a) (Map l Integer) -> Int -> [a] -> Map l Double scoreSequence m n xs = total where @@ -54,9 +56,11 @@ scores = map (scoreGram m) grams total = Map.unionsWith (+) (scores) + oneTerm :: (Ord l, Show l) => Map l Integer -> Map l Integer -> Map l (Maybe Float) oneTerm numers denoms = Map.empty + scoreGram :: (Ord l, Ord a, Show l, Show a) => Trie (Entry a) (Map l Integer) -> [(Entry a)] -> Map l Double scoreGram tr ns@(_:ns') = Map.map (toProb 256) vals where @@ -95,3 +99,4 @@ where xs' = map (\(l, is) -> [(l, x) | x <- revWindows n (replicate (n - 1) Start ++ (map Entry is))]) xs model = Trie.labeledSuffixCountTrie (concat xs') + diff --git a/src/Codec/Compression/PPM/Trie.hs b/src/Codec/Compression/PPM/Trie.hs --- a/src/Codec/Compression/PPM/Trie.hs +++ b/src/Codec/Compression/PPM/Trie.hs @@ -22,9 +22,9 @@ import qualified Data.List as L import Data.Foldable (toList) import qualified Data.Maybe as Maybe ---import Codec.Compression.PPM.Utils (windows) import Data.Serialize (Serialize) import GHC.Generics (Generic) + -- | Trie nodes may have an optional arbitrary value, and each edge is -- associated with a particular value seen in the input sequences. diff --git a/src/Codec/Compression/PPM/Utils.hs b/src/Codec/Compression/PPM/Utils.hs --- a/src/Codec/Compression/PPM/Utils.hs +++ b/src/Codec/Compression/PPM/Utils.hs @@ -3,6 +3,9 @@ module Codec.Compression.PPM.Utils ( lineToInstance , revWindows + , accuracy + , microFScore + , macroFScore ) where @@ -12,17 +15,28 @@ import Data.Foldable (toList) ---classify :: [ +-- | Calculates accuracy +accuracy :: (Eq a) => [a] -> [a] -> Double +accuracy golds guesses = correct / total + where + total = (fromIntegral . length) golds + correct = (fromIntegral . length) $ [x | (x, y) <- zip golds guesses, x == y] -- | Calculates micro F-Score -microFScore :: [a] -> [a] -> Double -microFScore guess gold = error "unimp" +microFScore :: (Eq a) => [a] -> [a] -> Double +microFScore guess gold = 1.0 + where + precs = [] + recs = [] -- | Calculates macro F-Score -macroFScore :: [a] -> [a] -> Double -macroFScore guess gold = error "unimp" +macroFScore :: (Eq a) => [a] -> [a] -> Double +macroFScore guess gold = 1.0 + where + precs = [] + recs = [] -- | Splits a line of format IDLABELTEXT into a