diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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}${label}${text} +``` + +When a model is applied to data, the output will generally have a header +with the format: + +``` +IDGOLD${label_1_name}${label_2_name}... +``` + +and lines with the corresponding format: + +``` +${doc_id}${gold_label_name}${label_1_prob}${label_2_prob}... +``` + +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. diff --git a/app/PPMClassifier.hs b/app/PPMClassifier.hs new file mode 100644 --- /dev/null +++ b/app/PPMClassifier.hs @@ -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 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 new file mode 100644 --- /dev/null +++ b/ngram.cabal @@ -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 diff --git a/src/Codec/Compression/PPM.hs b/src/Codec/Compression/PPM.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/PPM.hs @@ -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') diff --git a/src/Codec/Compression/PPM/Coding.hs b/src/Codec/Compression/PPM/Coding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/PPM/Coding.hs @@ -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 diff --git a/src/Codec/Compression/PPM/Trie.hs b/src/Codec/Compression/PPM/Trie.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/PPM/Trie.hs @@ -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) diff --git a/src/Codec/Compression/PPM/Utils.hs b/src/Codec/Compression/PPM/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/PPM/Utils.hs @@ -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 IDLABELTEXT 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