diff --git a/chatter.cabal b/chatter.cabal --- a/chatter.cabal +++ b/chatter.cabal @@ -1,5 +1,5 @@ name: chatter -version: 0.0.0.1 +version: 0.0.0.2 synopsis: A library of simple NLP algorithms. description: chatter is a collection of simple Natural Language Processing algorithms. @@ -112,6 +112,9 @@ Main-Is: Bench.hs hs-source-dirs: tests/src + Other-modules: NLP.Similarity.VectorSimBench + Corpora + Build-depends: chatter, criterion, filepath, @@ -128,6 +131,14 @@ Main-Is: Main.hs hs-source-dirs: tests/src + + Other-modules: AvgPerceptronTests + BackoffTaggerTests + NLP.Similarity.VectorSimTests + NLP.POSTests + NLP.POS.UnambiguousTaggerTests + Corpora + TestUtils Build-depends: chatter, base >= 4 && <= 6, diff --git a/tests/src/AvgPerceptronTests.hs b/tests/src/AvgPerceptronTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/AvgPerceptronTests.hs @@ -0,0 +1,57 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module AvgPerceptronTests where + +import Control.Applicative ((<$>)) +import Test.QuickCheck ( Arbitrary(..) ) +import Test.QuickCheck.Instances () +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework ( testGroup, Test ) + +import Data.Serialize (encode, decode) +import Data.Map (Map) + +import NLP.POS.AvgPerceptron + +tests :: Test +tests = testGroup "AvgPerceptron" + [ testGroup "Encoding tests" + [ testProperty "Features round-trip" prop_featureRoundtrips + , testProperty "Perceptrons round-trip" prop_perceptronRoundtrips + , testProperty "Map of features round-trip" prop_mapOfFeaturesRoundTrips + ] + ] + +prop_mapOfFeaturesRoundTrips :: Map Feature Class -> Bool +prop_mapOfFeaturesRoundTrips aMap = + case (decode . encode) aMap of + Left _ -> False + Right m -> m == aMap + +prop_featureRoundtrips :: Feature -> Bool +prop_featureRoundtrips feat = + case (decode . encode) feat of + Left _ -> False + Right f -> f == feat + +prop_perceptronRoundtrips :: Perceptron -> Bool +prop_perceptronRoundtrips per = + case (decode . encode) per of + Left _ -> False + Right p -> p == per + +instance Arbitrary Feature where + arbitrary = Feat <$> arbitrary + +instance Arbitrary Class where + arbitrary = Class <$> arbitrary + +instance Arbitrary Perceptron where + arbitrary = do ws <- arbitrary + ts <- arbitrary + times <- arbitrary + counts <- arbitrary + return Perceptron { weights = ws + , totals = ts + , tstamps = times + , instances = counts + } diff --git a/tests/src/BackoffTaggerTests.hs b/tests/src/BackoffTaggerTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/BackoffTaggerTests.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module BackoffTaggerTests where + +import Test.HUnit ( (@=?), Assertion ) +import Test.Framework ( testGroup, Test ) +import Test.Framework.Providers.HUnit (testCase) + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) + +import NLP.Types +import NLP.POS + +import qualified NLP.POS.LiteralTagger as LT + +tests :: Test +tests = testGroup "Backoff Tagging" + [ testCase "Simple back-off tagging" testLiteralBackoff + ] + +tagCat :: Map Text Tag +tagCat = Map.fromList [("cat", Tag "CAT")] + +tagAnimals :: Map Text Tag +tagAnimals = Map.fromList [("cat", Tag "NN"), ("dog", Tag "NN")] + +testLiteralBackoff :: Assertion +testLiteralBackoff = let + tgr = LT.mkTagger tagCat (Just $ LT.mkTagger tagAnimals Nothing) + actual = tag tgr "cat dog" + oracle = [[("cat", Tag "CAT"), ("dog", Tag "NN")]] + in oracle @=? actual diff --git a/tests/src/Corpora.hs b/tests/src/Corpora.hs new file mode 100644 --- /dev/null +++ b/tests/src/Corpora.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +module Corpora where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import System.FilePath (()) +import Text.Printf (printf) + +-- | A very small (one-sentence) training corpora for tests. +miniCorpora1 :: Text +miniCorpora1 = "the/DT dog/NN jumped/VB ./." + +miniCorpora2 :: Text +miniCorpora2 = T.unlines [ "the/DT dog/NN jumped/VB ./." + , "a/DT dog/NN barks/VB ./." + ] + +-- brownCorporaDir :: FilePath +-- brownCorporaDir = "/home/creswick/nltk_data/corpora/brown" + +-- brownCA01 :: FilePath +-- brownCA01 = brownCAFiles!!0 + +-- brownCA :: IO Text +-- brownCA = do +-- let files = brownCAFiles +-- contents <- mapM T.readFile files +-- return $ T.unlines contents + +-- brownFile :: String -> Int -> String +-- brownFile cat num = printf (cat++"%02d") num + +-- brownCAFiles :: [FilePath] +-- brownCAFiles = map (\n->brownCorporaDir (brownFile "ca" n)) [1..44] diff --git a/tests/src/NLP/POS/UnambiguousTaggerTests.hs b/tests/src/NLP/POS/UnambiguousTaggerTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/NLP/POS/UnambiguousTaggerTests.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module NLP.POS.UnambiguousTaggerTests where + +import Test.HUnit ( (@=?), Assertion ) +import Test.Framework ( testGroup, Test ) +import Test.Framework.Providers.HUnit (testCase) +import Test.QuickCheck () +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T + +import NLP.Types +import NLP.POS +import qualified NLP.POS.LiteralTagger as LT +import qualified NLP.POS.UnambiguousTagger as UT + +import TestUtils + +tests :: Test +tests = testGroup "NLP.POS.UnambiguousTagger" + [ testProperty "basic tag parsing" prop_emptyAlwaysUnk + , testGroup "Initial training" $ map (trainAndTagTest emptyTagger) + [ ("the/dt dog/nn jumped/vb", "a dog", "a/Unk dog/nn") + , ("the/dt dog/nn jumped/vb jumped/vbx", "a dog jumped", "a/Unk dog/nn jumped/Unk") + ] + , testGroup "Retraining" $ map (trainAndTagTest trainedTagger) + [ ("the/dt dog/nn jumped/vb", "the dog", "the/dt dog/Unk") + , ("the/dt dog/nn jumped/vb jumped/vbx", "the dog jumped", "the/dt dog/Unk jumped/Unk") + ] + ] + +emptyTagger :: POSTagger +emptyTagger = UT.mkTagger Map.empty Nothing + +trainedTagger :: POSTagger +trainedTagger = UT.mkTagger (Map.fromList [("the", Tag "dt"), ("dog", Tag "vb")]) Nothing + +prop_emptyAlwaysUnk :: String -> Bool +prop_emptyAlwaysUnk input = all (\(_, y) -> y == tagUNK) (concat $ tag emptyTagger inputTxt) + where inputTxt = T.pack input + +trainAndTagTest :: POSTagger -> (Text, Text, Text) -> Test +trainAndTagTest tgr (exs, input, oracle) = testCase (T.unpack (T.intercalate ": " [exs, input])) $ do + trained <- trainText tgr exs + oracle @=? tagText trained input diff --git a/tests/src/NLP/POSTests.hs b/tests/src/NLP/POSTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/NLP/POSTests.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +module NLP.POSTests where + +import Test.HUnit ( (@=?), Assertion ) +import Test.Framework ( testGroup, Test ) +import Test.Framework.Providers.HUnit (testCase) +import Test.QuickCheck.Instances () +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) + +import NLP.Types +import NLP.POS +import qualified NLP.POS.LiteralTagger as LT + +import TestUtils + +tests :: Test +tests = testGroup "NLP.POS" + [ testGroup "Evaluation" $ map (genTestF $ eval mamalTagger) + [ ("Half", [ [ ("the", Tag "DT"), ("cat", Tag "NN")] + , [ ("the", Tag "DT"), ("dog", Tag "NN")] ], 0.5) + , ("All ", [ [ ("dog", Tag "NN"), ("cat", Tag "NN")] ], 1.0) + , ("None", [ [ ("the", Tag "DT"), ("couch", Tag "NN")] ], 0) + ] + , testGroup "Serialization" + [ testProperty "1 LiteralTagger" (prop_taggersRoundTrip mamalTagger) + , testProperty "2 LiteralTaggers" (prop_taggersRoundTrip animalTagger) + ] + ] + +animalTagger :: POSTagger +animalTagger = LT.mkTagger (Map.fromList [("owl", Tag "NN"), ("flea", Tag "NN")]) (Just mamalTagger) + +mamalTagger :: POSTagger +mamalTagger = LT.mkTagger (Map.fromList [("cat", Tag "NN"), ("dog", Tag "NN")]) Nothing + +-- TODO need to make random taggers to really test this... +prop_taggersRoundTrip :: POSTagger -> String -> Bool +prop_taggersRoundTrip tgr input = + let Right roundTripped = deserialize taggerTable $ serialize tgr + in tagStr tgr ("cat owl " ++ input) == tagStr roundTripped ("cat owl " ++ input) diff --git a/tests/src/NLP/Similarity/VectorSimBench.hs b/tests/src/NLP/Similarity/VectorSimBench.hs new file mode 100644 --- /dev/null +++ b/tests/src/NLP/Similarity/VectorSimBench.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +module NLP.Similarity.VectorSimBench where + +import Data.List.Split (splitWhen) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Criterion (bench, whnf, Benchmark) + +import NLP.Tokenize (tokenize) +import NLP.Similarity.VectorSim +import NLP.Types (mkCorpus, Corpus) + +benchmarks :: [[Text]] -> [[Text]] -> [Benchmark] +benchmarks docs testDocs = let + corpus = mkCorpus docs + in [ bench "Doc 1-2 vs 3-4" $ whnf (similarity corpus (concat $ take 2 testDocs)) + ((testDocs!!2) ++ (testDocs!!3)) + , bench "Doc 1-5 vs 6-10" $ whnf (similarity corpus (concat $ take 5 testDocs)) + (concat $ take 5 $ drop 5 testDocs) + , bench "all pairs of 1-5" $ whnf (docsRunAllPairs corpus) (take 5 testDocs) + + , bench "TV all pairs of 1-5" $ whnf (tvDocsRunAllPairs corpus) (take 5 testDocs) + ] + +docsRunAllPairs :: Corpus -> [[Text]] -> Double +docsRunAllPairs _ [] = 0 +docsRunAllPairs corpus (d:ds) = let + firstRow = foldl (\v doc -> v + similarity corpus d doc) 0 ds + in firstRow + (docsRunAllPairs corpus ds) + +tvDocsRunAllPairs :: Corpus -> [[Text]] -> Double +tvDocsRunAllPairs corpus docs = runVectors (map (mkVector corpus) docs) + where + runVectors :: [TermVector] -> Double + runVectors [] = 0 + runVectors (d:ds) = let + firstRow = foldl (\v doc -> v + tvSim d doc) 0 ds + in firstRow + (runVectors ds) + + +readMucCorpus :: String -> IO [[Text]] +readMucCorpus file = do + content <- T.readFile ("./tests/resources/corpora/muc3_4/"++file) + let + docMarker :: Text -> Bool + docMarker txt = "DEV-MUC3-" `T.isPrefixOf` txt + + docLines :: [[Text]] + docLines = splitWhen docMarker $ T.lines content + + documents :: [Text] + documents = map T.unlines docLines + + return $ map tokenize documents + +muc3_01 :: IO [[Text]] +muc3_01 = readMucCorpus "dev-muc3-0001-0100" + +muc3_02 :: IO [[Text]] +muc3_02 = readMucCorpus "dev-muc3-0101-0200" + +muc3_03 :: IO [[Text]] +muc3_03 = readMucCorpus "dev-muc3-0201-0300" diff --git a/tests/src/NLP/Similarity/VectorSimTests.hs b/tests/src/NLP/Similarity/VectorSimTests.hs new file mode 100644 --- /dev/null +++ b/tests/src/NLP/Similarity/VectorSimTests.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +module NLP.Similarity.VectorSimTests where + +import Control.Monad (unless) +import Test.HUnit ( (@=?), Assertion, assertBool, assertFailure ) +import Test.QuickCheck ( Arbitrary(..), Property, (==>), elements ) +import Test.QuickCheck.Property () +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework ( testGroup, Test) +-- import Test.Framework.Skip (skip) + +import Data.Text (Text) +import qualified Data.Text as T + +import NLP.Similarity.VectorSim +import NLP.Types (mkCorpus) + +import TestUtils + +tests :: Test +tests = testGroup "Vector Sim" + [ -- testGroup "Dot Products" $ map (genTestF2 dotProd) + -- [ ("3-4-5", [1,3,-5], [4, -2, -1], 3) + -- , ("identical", [1], [1], 1.0) + -- , ("orthogonal", [1,0], [0,1], 0) + -- ] + -- , testGroup "cosines" $ map (genTestF2 cosVec) + -- -- ("identical", [0], [0], NaN) -- can't determine the angle. + -- [ ("identical", [1], [1], 1.0) + -- , ("identical", [1,2], [1,2], 1.0) + -- , ("orthogonal", [1,0], [0,1], 0) + -- ] + -- , testGroup "Magnitude tests" $ map (genTest magnitude) + -- [ ("3-4-5", [3,4], 5) + -- , ("empty", [], 0) + -- , ("single", [1], 1) + -- ] + testGroup "tf tests" $ map (genTest2 tf) + [ ("", "test", ["test"], 1) + , ("", "a", ["a", "test"], 1) + , ("", "a", ["test"], 0) + ] + , testGroup "idf tests" $ map (genTestF2 idf) + [ ("", "test", mkCorpus [["test"]], log(1/2)) + , ("", "a", mkCorpus [["test"]], log(1)) + , ("", "a", mkCorpus [["a", "test"],["test"]], log(2/2)) + ] + , testGroup "tf_idf tests" $ map (genTestF3 tf_idf) + [ ("", "test", ["test"], mkCorpus [["test"]], log(2/3)) + , ("", "a", ["a", "test"], mkCorpus [["some"], ["test"]], 0.40546) + , ("", "foo", ["foo"], mkCorpus [["test"]], 0) + , ("", "foo", ["foo"], mkCorpus [["foo"],["test"]], 0) + , ("", "bar", ["foo"], mkCorpus [["test"]], 0) + , ("", "bar", ["foo"], mkCorpus [["foo"],["test"]], 0) + ] + , testGroup "Similarity tests, trivial corpus" $ + map (genTest2 $ sim $ mkCorpus [["test"]]) + [ ("same doc", "test", "test", 1) + -- This next test is invalid becausse the + -- initial smoothing causes funny results (this + -- should not be 1.0, and it /is not/ when the + -- corpus is bigger.) + , ("one off", "a test", "the test", 1.0) + , ("No match", "foo", "bar", 0.0) + ] + , testGroup "Similarity tests, minor corpus" $ + map (genTestF2 $ sim $ mkCorpus [ ["a", "sample"] + , ["the", "test"] + , ["big", "example"] + , ["more", "terms"]]) + [ ("same doc", "test", "test", 1) + , ("one off", "a test", "the test", 0.5) + , ("No match", "foo", "bar", 0.0) + ] + , testProperty "idf /= NaN" prop_idfIsANum + , testProperty "tf_idf /= NaN" prop_tf_idfIsANum + , testProperty "similarity /= NaN" prop_similarity_isANum + ] + +prop_idfIsANum :: String -> [[String]] -> Bool +prop_idfIsANum term docs = not (isNaN (idf termTxt $ mkCorpus docsTxt)) + where + termTxt = T.pack term + docsTxt = map (map T.pack) docs + +prop_tf_idfIsANum :: String -> [String] -> [[String]] -> Bool +prop_tf_idfIsANum term doc docs = not $ isNaN $ tf_idf termTxt docTxt $ mkCorpus docsTxt + where + termTxt = T.pack term + docTxt = map T.pack doc + docsTxt = map (map T.pack) docs + +prop_similarity_isANum :: [[String]] -> [String] -> [String] -> Property +prop_similarity_isANum strCorp d1 d2 = strCorp /= [] && + (concat d1 /= []) && + (concat d2 /= [])==> let + corpus = mkCorpus $ map (map T.pack) strCorp + doc1 = map T.pack d1 + doc2 = map T.pack d2 + in not $ isNaN $ similarity corpus doc1 doc2 diff --git a/tests/src/TestUtils.hs b/tests/src/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/src/TestUtils.hs @@ -0,0 +1,53 @@ +module TestUtils where + + +import Control.Monad (unless) +import Test.HUnit ( (@=?), Assertion, assertFailure ) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework (Test) + +genTestF2 :: (Show a, Show b) => (a -> b -> Double) -> (String, a, b, Double) -> Test +genTestF2 fn (descr, in1, in2, oracle) = + testCase (descr++" [input: "++show in1++"," ++show in2++"]") assert + where assert = assertApproxEquals "" 0.001 oracle $ fn in1 in2 + +genTest3 :: (Show a, Show b, Show c, Show d, Eq d) + => (a -> b -> c -> d) + -> (String, a, b, c, d) + -> Test +genTest3 fn (descr, in1, in2, in3, oracle) = + testCase (descr++" [input: "++show in1++"," ++show in2++"," ++show in3++"]") assert + where assert = oracle @=? fn in1 in2 in3 + +genTestF3 :: (Show a, Show b, Show c) + => (a -> b -> c -> Double) + -> (String, a, b, c, Double) + -> Test +genTestF3 fn (descr, in1, in2, in3, oracle) = + testCase (descr++" [input: "++show in1++"," ++show in2++"," ++show in3++"]") assert + where assert = assertApproxEquals "" 0.001 oracle $ fn in1 in2 in3 + +genTest2 :: (Show a, Show b, Show c, Eq c) => (a -> b -> c) -> (String, a, b, c) -> Test +genTest2 fn (descr, in1, in2, oracle) = + testCase (descr++" [input: "++show in1++"," ++show in2++"]") assert + where assert = oracle @=? fn in1 in2 + +genTest :: (Show a, Show b, Eq b) => (a -> b) -> (String, a, b) -> Test +genTest fn (descr, input, oracle) = + testCase (descr++" [input: "++show input++"]") assert + where assert = oracle @=? fn input + +genTestF :: Show a => (a -> Double) -> (String, a, Double) -> Test +genTestF fn (descr, input, oracle) = + testCase (descr++" [input: "++show input++"]") assert + where assert = assertApproxEquals "" 0.001 oracle $ fn input + +assertApproxEquals :: String -- ^ The message prefix + -> Double -- ^ The maximum difference between expected and actual + -> Double -- ^ The expected value + -> Double -- ^ The actual value + -> Assertion +assertApproxEquals preface delta expected actual = + unless (abs (expected - actual) < delta) (assertFailure msg) + where msg = (if null preface then "" else preface ++ "\n") ++ + "expected: " ++ show expected ++ "\n but got: " ++ show actual