packages feed

chatter 0.6.0.0 → 0.7.0.0

raw patch · 6 files changed

+145/−10 lines, 6 files

Files

changelog.md view
@@ -1,3 +1,15 @@+= 0.7.0.0 =+ - B-level version bump because we added test dependency on+   unordered-containers, which could cause downstream issues.++ - TermVector: is a newtype now, and has its own arbitrary instance.++ - TermVector: adds addVectors, zeroVector, negate, and sum++ - DefaultMap: adds elems, map, and unionWith++ - Adds quickcheck properties for all of the above+ = 0.6.0.0 =   - Switched to using Hashmap for the DefaultMap implementation;
chatter.cabal view
@@ -1,5 +1,5 @@ name:                chatter-version:             0.6.0.0+version:             0.7.0.0 synopsis:            A library of simple NLP algorithms. description:         chatter is a collection of simple Natural Language                      Processing algorithms.@@ -232,6 +232,7 @@                      tasty,                      tasty-quickcheck,                      tasty-hunit,-                     tasty-ant-xml+                     tasty-ant-xml,+                     unordered-containers     ghc-options:      -Wall -auto-all -caf-all
src/Data/DefaultMap.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-} module Data.DefaultMap where +import Prelude hiding (lookup) import Control.Applicative ((<$>), (<*>)) import Test.QuickCheck (Arbitrary(..)) import Control.DeepSeq (NFData)+import qualified Data.HashSet as S import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map@@ -43,6 +46,14 @@ keys :: DefaultMap k a -> [k] keys m = Map.keys (defMap m) +-- | Access the non-default values as a list.+elems :: DefaultMap k a -> [a]+elems = Map.elems . defMap++-- | Map a function over the values in a map.+map :: (a -> a) -> DefaultMap k a -> DefaultMap k a+map f m = m { defMap = f <$> defMap m }+ -- | Fold over the values in the map. -- -- Note that this *does* not fold@@ -50,6 +61,29 @@ -- standard `Data.Map.foldl` foldl :: (a -> b -> a) -> a -> DefaultMap k b -> a foldl fn acc m = Map.foldl' fn acc (defMap m)++-- | Compute the union of two maps using the specified per-value+-- combination function and the specified new map default value.+unionWith :: forall v k . (Eq k, Hashable k)+          => (v -> v -> v)+          -- ^ Combine values with this function+          -> v+          -- ^ The new map's default value+          -> DefaultMap k v+          -- ^ The first map to combine+          -> DefaultMap k v+          -- ^ The second map to combine+          -> DefaultMap k v+unionWith f newDef a b =+    let allKeys = S.unions [ S.fromList $ Map.keys $ defMap a+                           , S.fromList $ Map.keys $ defMap b+                           ]+        mergeKey :: k -> Map.HashMap k v -> Map.HashMap k v+        mergeKey k m = Map.insert k (f (lookup k a) (lookup k b)) m++    in DefMap { defDefault = newDef+              , defMap = S.foldr mergeKey Map.empty allKeys+              }  instance (Arbitrary k, Arbitrary v, Hashable k, Eq k) => Arbitrary (DefaultMap k v) where   arbitrary = do
src/NLP/Similarity/VectorSim.hs view
@@ -1,21 +1,35 @@+{-# LANGUAGE DeriveGeneric #-} module NLP.Similarity.VectorSim where +import Prelude hiding (lookup) import Data.DefaultMap (DefaultMap)+import Test.QuickCheck (Arbitrary(..)) import qualified Data.DefaultMap as DM import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.List (elemIndices)-+import GHC.Generics import NLP.Types  -- | An efficient (ish) representation for documents in the "bag of -- words" sense.-type TermVector = DefaultMap Text Double+newtype TermVector = TermVector (DefaultMap Text Double)+  deriving (Read, Show, Eq, Generic) +instance Arbitrary TermVector where+  arbitrary = do+    theMap <- arbitrary+    let zeroMap = theMap { DM.defDefault = 0 }+    return $ TermVector zeroMap++-- | Access the underlying DefaultMap used to store term vector details.+fromTV :: TermVector -> DefaultMap Text Double+fromTV (TermVector dm) = dm+ -- | Generate a `TermVector` from a tokenized document. mkVector :: Corpus -> [Text] -> TermVector-mkVector corpus doc = DM.fromList 0 $ Set.toList $+mkVector corpus doc = TermVector $ DM.fromList 0 $ Set.toList $                         Set.map (\t->(t, tf_idf t doc corpus)) (Set.fromList doc)  @@ -89,9 +103,28 @@   mag = (magnitude vec1 * magnitude vec2)   in dp / mag +-- | Add two term vectors. When a term is added, its value in each+-- vector is used (or that vector's default value is used if the term+-- is absent from the vector). The new term vector resulting from the+-- addition always uses a default value of zero.+addVectors :: TermVector -> TermVector -> TermVector+addVectors vec1 vec2 = TermVector (DM.unionWith (+) 0 (fromTV vec1) (fromTV vec2))++-- | A "zero vector" term vector (i.e. @addVector v zeroVector = v@).+zeroVector :: TermVector+zeroVector = TermVector (DM.empty 0)++-- | Negate a term vector.+negate :: TermVector -> TermVector+negate vec = TermVector (DM.map ((-1) *) $ fromTV vec)++-- | Add a list of term vectors.+sum :: [TermVector] -> TermVector+sum = foldr addVectors zeroVector+ -- | Calculate the magnitude of a vector. magnitude :: TermVector -> Double-magnitude v = sqrt $ DM.foldl acc 0 v+magnitude v = sqrt $ DM.foldl acc 0 $ fromTV v   where     acc :: Double -> Double -> Double     acc cur new = cur + (new ** 2)@@ -99,5 +132,12 @@ -- | find the dot product of two vectors. dotProd :: TermVector -> TermVector -> Double dotProd xs ys = let-  terms = Set.fromList (DM.keys xs) `Set.union` Set.fromList (DM.keys ys)-  in Set.foldl (+) 0 (Set.map (\t -> (DM.lookup t xs) * (DM.lookup t ys)) terms)+  terms = Set.fromList (keys xs) `Set.union` Set.fromList (keys ys)+  in Set.foldl (+) 0 (Set.map (\t -> (lookup t xs) * (lookup t ys)) terms)++keys :: TermVector -> [Text]+keys tv = DM.keys $ fromTV tv++lookup :: Text -> TermVector -> Double+lookup key tv = DM.lookup key $ fromTV tv+
tests/src/Data/DefaultMapTests.hs view
@@ -1,21 +1,50 @@ module Data.DefaultMapTests where +import Control.Applicative ((<$>))+import qualified Data.HashSet as S+import qualified Data.Text as T import Test.QuickCheck.Instances () import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty)+import Data.Function (on)+import Data.List (nubBy)  import Data.Serialize (decode, encode) -import Data.DefaultMap (DefaultMap(..))+import qualified Data.DefaultMap as DM  tests :: TestTree tests = testGroup "NLP.Data.DefaultMapTests"         [ testGroup "Serialize / Deserialize Tests"           [ testProperty "DefaultMap round-trips" prop_defMapSerialize+          , testProperty "DefaultMap elems" prop_elems+          , testProperty "DefaultMap unionWith" prop_unionWith+          , testProperty "DefaultMap map" prop_map           ]         ] -prop_defMapSerialize :: DefaultMap String String -> Bool+prop_defMapSerialize :: DM.DefaultMap String String -> Bool prop_defMapSerialize c = case (decode . encode) c of                            Right c' -> c == c'                            Left _ -> False++prop_elems :: [(T.Text, Int)] -> Bool+prop_elems pairs =+    let uPairs = nubBy ((==) `on` fst) pairs+    in (S.fromList $ snd <$> uPairs) ==+       (S.fromList $ DM.elems $ DM.fromList 0 uPairs)++prop_map :: [(T.Text, Int)] -> Bool+prop_map pairs =+    let uPairs = nubBy ((==) `on` fst) pairs+        f = (+ 4)+    in (S.fromList $ f <$> snd <$> uPairs) ==+       (S.fromList $ DM.elems $ DM.map f $ DM.fromList 0 uPairs)++prop_unionWith :: DM.DefaultMap T.Text Int -> DM.DefaultMap T.Text Int -> Bool+prop_unionWith a b =+    let f = (+)+        result = DM.unionWith f 0 a b+    in and [ f (DM.lookup k a) (DM.lookup k b) == DM.lookup k result+           | k <- S.toList $ S.fromList (DM.keys a ++ DM.keys b)+           ]
tests/src/NLP/Similarity/VectorSimTests.hs view
@@ -1,12 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module NLP.Similarity.VectorSimTests where +import Prelude hiding (negate, sum) import Test.QuickCheck ( Property, (==>) ) import Test.QuickCheck.Property () import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty)  import qualified Data.Text as T+import qualified NLP.Similarity.VectorSim as TV  import NLP.Similarity.VectorSim import NLP.Types (mkCorpus)@@ -71,7 +73,24 @@         , testProperty "idf /= NaN" prop_idfIsANum         , testProperty "tf_idf /= NaN" prop_tf_idfIsANum         , testProperty "similarity /= NaN" prop_similarity_isANum+        , testProperty "v + 0 = v" prop_addVectorZero+        , testProperty "v - v = 0" prop_negateVector         ]++prop_addVectorZero :: TermVector -> Bool+prop_addVectorZero v = addVectors v zeroVector == v &&+                       addVectors zeroVector v == v++prop_negateVector :: TermVector -> Bool+prop_negateVector v =+    let theSum = addVectors v (negate v)+    in and [ TV.lookup k theSum == 0+           | k <- TV.keys v+           ]++prop_sum :: [TermVector] -> Bool+prop_sum vs =+    foldr addVectors zeroVector vs == sum vs  prop_idfIsANum :: String -> [[String]] -> Bool prop_idfIsANum term docs = not (isNaN (idf termTxt $ mkCorpus docsTxt))