ngram (empty) → 0.1.0.0
raw patch · 8 files changed
+566/−0 lines, 8 filesdep +basedep +bytestringdep +cereal
Dependencies added: base, bytestring, cereal, cereal-text, containers, ngram, optparse-generic, text, zlib
Files
- LICENSE +30/−0
- README.md +57/−0
- app/PPMClassifier.hs +71/−0
- ngram.cabal +63/−0
- src/Codec/Compression/PPM.hs +97/−0
- src/Codec/Compression/PPM/Coding.hs +129/−0
- src/Codec/Compression/PPM/Trie.hs +63/−0
- src/Codec/Compression/PPM/Utils.hs +56/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++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.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++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.
+ README.md view
@@ -0,0 +1,57 @@+# NGrams++This is a code base for experimenting with various approaches to n-gram-based+text modeling. To get started, run:++```bash+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:++```+${id}<TAB>${label}<TAB>${text}+```++When a model is applied to data, the output will generally have a header+with the format:++```+ID<TAB>GOLD<TAB>${label_1_name}<TAB>${label_2_name}<TAB>...+```++and lines with the corresponding format:++```+${doc_id}<TAB>${gold_label_name}<TAB>${label_1_prob}<TAB>${label_2_prob}<TAB>...+```++where probabilities are represented as natural logarithms.++The remainder of this document describes the implemented models, most of which+have a corresponding command that *stack* will have installed. The library aims+to be parametric over the sequence types, and most commands allow users to +specify whether to consider bytes, unicode characters, or whitespace-delimited +tokens.++## Prediction by Partial Matching++PPM is essentially an n-gram model with a particular backoff logic that can't +quite be reduced to more widespread approaches to smoothing, but empirically +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+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+```++The value of `--n` can also be less than the model size, which will run a bit +faster, and (perhaps) less tuned to the original training data.
+ app/PPMClassifier.hs view
@@ -0,0 +1,71 @@+{-# 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 ID<TAB>LABEL<TAB>TEXT 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+ +
+ ngram.cabal view
@@ -0,0 +1,63 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: af4ceddbe5e5c69c25bcb8f6b1751761dbfff6d66511ba80f8b6cde5cba29c91++name: ngram+version: 0.1.0.0+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+homepage: https://github.com/TomLippincott/ngram#readme+bug-reports: https://github.com/TomLippincott/ngram/issues+author: Tom Lippincott+maintainer: tom@cs.jhu.edu+copyright: 2018 Tom Lippincott+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/TomLippincott/ngram++library+ exposed-modules:+ Codec.Compression.PPM+ Codec.Compression.PPM.Coding+ Codec.Compression.PPM.Trie+ Codec.Compression.PPM.Utils+ other-modules:+ Paths_ngram+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , cereal >=0.5.4.0+ , cereal-text >=0.1.0.2+ , containers >=0.5.10.2+ , text >=1.2.2+ default-language: Haskell2010++executable ppm+ main-is: PPMClassifier.hs+ other-modules:+ Paths_ngram+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts+ build-depends:+ base >=4.7 && <5+ , bytestring >=0.10.8.1+ , cereal >=0.5.4.0+ , cereal-text >=0.1.0.2+ , containers >=0.5.10.2+ , ngram+ , optparse-generic >=1.2.2+ , text >=1.2.2+ , zlib >=0.6.1+ default-language: Haskell2010
+ src/Codec/Compression/PPM.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExplicitNamespaces #-}++module Codec.Compression.PPM ( Model+ , fromSequences+ , classifySequence+ , scoreSequence+ ) where++import Prelude hiding (lookup)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy.IO as T+import qualified Data.Text.Lazy.Encoding as T+import qualified Data.Sequence as Seq+import Data.Foldable (toList)+import Data.Sequence ((|>))+import qualified Codec.Compression.PPM.Trie as Trie+import Codec.Compression.PPM.Trie (Trie(..))+import Data.Map (Map)+import qualified Data.Map as Map+import Codec.Compression.PPM.Utils (revWindows)+import qualified Data.Maybe as Maybe+import Data.List (sortOn, maximumBy)+import Control.Monad (join)+import Debug.Trace (traceShowId)+import Data.Serialize (Serialize)+import GHC.Generics (Generic)++data Entry a = Entry a | Start deriving (Show, Read, Ord, Eq, Generic)++instance (Serialize a, Ord a) => Serialize (Entry a)++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+ xs' = map Entry xs+ grams = revWindows n xs'+ 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+ numer = Map.map tail (toCounts tr ns)+ denom = toCounts tr ns'+ n = length ns+ inf = repeat 0+ vals = Map.intersectionWith (\a b -> reverse $ take n $ zip (a ++ inf) (b ++ inf)) numer denom+++toProb :: Int -> [(Integer, Integer)] -> Double+toProb alph xs = go xs 0.0+ where+ go [] acc = acc + (log (1.0 / fromIntegral alph))+ go ((0, 0):xs') acc = go xs' (acc + (log (1.0 / 2.0)))+ go ((0, d):xs') acc = go xs' (acc + (log (1.0 / (fromIntegral d + 1.0))))+ go ((n, d):xs') acc = (acc + (log ((fromIntegral n) / (fromIntegral d + 1.0))))+++toCounts :: (Ord l, Ord a, Show l, Show a) => Trie a (Map l Integer) -> [a] -> Map l [Integer]+toCounts tr xs = go start tr xs+ where+ start = Map.fromList [(l, []) | l <- (Map.keys . value) tr]+ go acc Trie{..} cs = case cs of+ [] -> acc'+ (c:cs') -> case edges Map.!? c of+ Nothing -> acc'+ Just tr' -> go acc' tr' cs'+ where+ lvalue = Map.map (\x -> [x]) value+ acc' = Map.unionWith (\a b -> a ++ b) acc lvalue+++fromSequences :: (Ord l, Ord a, Show l, Show a) => Int -> [(l, [a])] -> Trie (Entry a) (Map l Integer)+fromSequences n xs = model+ where+ xs' = map (\(l, is) -> [(l, x) | x <- revWindows n (replicate (n - 1) Start ++ (map Entry is))]) xs+ model = Trie.labeledSuffixCountTrie (concat xs')
+ src/Codec/Compression/PPM/Coding.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE RecordWildCards #-}++module Codec.Compression.PPM.Coding (-- encode+ --, decode+ --, probability+ --, shiftCommonPrefix+ --, bitsToInteger+ ) where+import Prelude hiding (subtract, lookup, last)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Maybe as M+import Data.Bits+import Control.Monad (join, liftM)+import qualified Data.List as L+import Data.Foldable (toList)+import qualified Data.Sequence as Seq+import Data.Sequence ((|>))+--import Codec.Compression.PPM.Trie (Trie(..), lookup)+--import Codec.Compression.PPM.Utils (windows)+import Data.Ratio ((%))+import Debug.Trace hiding (trace)++-- first :: Word+-- first = zeroBits `setBit` 0++-- last :: Word+-- last = zeroBits `setBit` i+-- where+-- i = (finiteBitSize first) - 1++-- secondToLast :: Word+-- secondToLast = zeroBits `setBit` i+-- where+-- i = (finiteBitSize first) - 2+++-- shiftCommonPrefix :: State -> State+-- shiftCommonPrefix (State {..}) = case lb == hb of+-- True -> State { low=low `shiftL` 1, high=high `shiftL` 1 `setBit` 0, underflow=underflow, bits=lb:bits }+-- False -> case lsb /= hsb of+-- True -> State { low=low, high=high, underflow=underflow, bits=bits }+-- False -> State { low=low, high=high, underflow=underflow, bits=bits } +-- where+-- i = (finiteBitSize low) - 1+-- lb = low `testBit` i+-- hb = high `testBit` i+-- lsb = low `testBit` (i - 1)+-- hsb = high `testBit` (i - 1)++-- --where+ +-- -- go l' h' bs = case lb == hb of+-- -- True -> go (shiftL l' 1 `clearBit` 0) (shiftL h' 1 `setBit` 0) (lb:bs)+-- -- False -> (bs, l', h')++-- bitsToInteger :: [Bool] -> Integer+-- bitsToInteger = go 0+-- where+-- go i [] = i+-- go i (b:bs) = go ((if b == True then setBit else clearBit) (i `shift` 1) 0) bs++-- data Symbol = Symbol { lowCount :: Integer+-- , highCount :: Integer+-- , scale :: Integer+-- } deriving (Show)++-- data State = State { low :: Word+-- , high :: Word+-- , underflow :: Int+-- , bits :: [Bool]+-- } deriving (Show)++-- type Code = Trie (Maybe Char) (Integer, Integer)++-- -- -- | Under a given trie and with the current range, return the updated range+-- -- updateRange :: Code -> Word -> Word -> [Maybe Char] -> (Word, Word)+-- -- updateRange tr cl ch i = shiftCommonPrefix l' h'+-- -- where+-- -- range = (ch - cl) + 1+-- -- Just (nl, nh) = case lookup i tr of+-- -- Nothing -> error $ "No entry for: " ++ show es+-- -- Just x -> value x+-- -- Just (_, sc) = value tr+-- -- l' = cl + ((range * nl) `div` sc)+-- -- h' = cl + ((range * nh) `div` sc) - 1++-- trace :: (Show a) => a -> a+-- trace a = a -- traceShow a a++-- trace' :: (Show a) => String -> a -> a+-- trace' s a = a --traceShow (s, a) a++-- -- | +-- encodeItem :: State -> Symbol -> State+-- encodeItem (State{..}) (Symbol{..}) = shiftCommonPrefix $ State { low=fromIntegral (trace low'), high=fromIntegral (trace high'), underflow=underflow, bits=bits }+-- where+-- range = trace' "range: " $ (fromIntegral $ high - low :: Integer) + 1 +-- l = fromIntegral low+-- low' = l + (range * lowCount) `div` scale+-- high' = l + (range * highCount) `div` scale - 1+-- --(shifted, low'', high'') = shiftCommonPrefix low' high'++-- type Input = [Maybe Char]++-- encode :: Code -> Int -> Input -> [Bool]+-- encode code n xs = (reverse . bits) $ foldl encodeItem iState cs''+-- where+-- iState = State zeroBits (complement zeroBits) 0 []+-- Just (_, top) = value code+-- cs = [lookup i code | i <- windows n xs]+-- cs' = [value tr | Just tr <- cs]+-- cs'' = trace [Symbol l h top | Just (l, h) <- cs']++-- decode :: Trie e v -> Integer -> [e]+-- decode tr i = go tr i []+-- where+-- go tr' i' (Nothing:bs) = M.catMaybes $ reverse bs+-- go tr' i' bs = go tr' i' (Nothing:bs)++-- probability :: Trie e v -> [e] -> Double+-- probability tr xs = 0.5
+ src/Codec/Compression/PPM/Trie.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ExplicitNamespaces #-}++module Codec.Compression.PPM.Trie ( Trie(..)+ , Context(..)+ , lookup+ , labeledSuffixCountTrie+ ) where++import Prelude hiding (lookup)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Bits+import Control.Monad (join, liftM)+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.+data Trie e v = Trie { value :: v+ , edges :: Map e (Trie e v)+ } deriving (Show, Read, Generic)+++instance (Serialize e, Serialize v, Ord e, Ord v) => Serialize (Trie e v)++data Context v c = Context Int+++addSequenceWithLabel :: (Ord l, Ord e) => Trie e (Map l Integer) -> (l, [e]) -> Trie e (Map l Integer)+addSequenceWithLabel (Trie{..}) (l, []) = Trie { value=value'+ , edges=edges+ }+ where+ value' = Map.insertWith (+) l 1 value++addSequenceWithLabel (Trie{..}) (l, (x:xs)) = Trie { value=value'+ , edges=edges'+ }+ where+ old = Map.findWithDefault (Trie Map.empty Map.empty) x edges+ edges' = Map.insert x (addSequenceWithLabel old (l, xs)) edges+ value' = Map.insertWith (+) l 1 value+ ++labeledSuffixCountTrie :: (Ord l, Ord e) => [(l, [e])] -> Trie e (Map l Integer)+labeledSuffixCountTrie xs = foldl addSequenceWithLabel (Trie Map.empty Map.empty) xs+++lookup :: (Ord e) => [e] -> Trie e v -> Maybe (Trie e v)+lookup [] tr = Just tr+lookup (e:es) (Trie {..}) = join $ lookup es <$> (edges Map.!? e)
+ src/Codec/Compression/PPM/Utils.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+++module Codec.Compression.PPM.Utils ( lineToInstance+ , revWindows+ ) where+++import qualified Data.Text.Lazy as T+import qualified Data.Sequence as Seq+import Data.Sequence ((|>))+import Data.Foldable (toList)+++--classify :: [+++-- | Calculates micro F-Score+microFScore :: [a] -> [a] -> Double+microFScore guess gold = error "unimp"+++-- | Calculates macro F-Score+macroFScore :: [a] -> [a] -> Double+macroFScore guess gold = error "unimp"+++-- | Splits a line of format ID<TAB>LABEL<TAB>TEXT into a+-- (label, document) tuple of (Text, [Char]).+lineToInstance :: T.Text -> (T.Text, [Char])+lineToInstance l = (label, T.unpack (T.drop 1 text))+ where+ (id, rest) = T.breakOn "\t" l+ (label, text) = T.breakOn "\t" (T.drop 1 rest)+++-- | Returns all subsequences of a given length.+-- Includes initial shorter sequences.+windows :: Int -> [a] -> [[a]]+windows n0 = go 0 Seq.empty+ where+ go n s (a:as) | n' <= n0 = toList s' : go n' s' as+ | otherwise = toList s'' : go n s'' as+ where+ n' = n + 1+ s' = s |> a+ s'' = Seq.drop 1 s'+ go _ _ [] = []+++-- | Reverse-order windows of given length from input sequence.+-- Includes shorter initial windows.+revWindows :: Int -> [i] -> [[i]]+revWindows n is = is'+ where+ is' = (map reverse . windows n) is