diff --git a/NLP/Scores.hs b/NLP/Scores.hs --- a/NLP/Scores.hs +++ b/NLP/Scores.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE + BangPatterns + , NoMonomorphismRestriction + #-} -- | Scoring functions commonly used for evaluation of NLP -- systems. Most functions in this module work on sequences which are -- instances of 'Data.Foldable', but some take a precomputed table of @@ -7,7 +10,7 @@ -- Information, Variation of Information and the Adjusted Rand Index -- on the same pair of clusterings: -- --- >>> let cs = counts $ zip "abcabc" "abaaba" +-- >>> let cs = counts "abcabc" "abaaba" -- >>> mapM_ (print . ($ cs)) [mi, ari, vi] -- >>> 0.9182958340544894 -- >>> 0.4444444444444445 @@ -15,15 +18,15 @@ module NLP.Scores ( - -- * Scores for classification and ranking + -- * Scores for classification and ranking accuracy , recipRank , avgPrecision - -- * Scores for clustering + -- * Scores for clustering , ari , mi , vi - -- * Auxiliary types and functions + -- * Auxiliary types and functions , Count , Counts , counts @@ -31,20 +34,31 @@ , mean , jaccard , entropy + , histogram + -- * Extracting joint and marginal counts from 'Counts' + , countJoint + , countFst + , countSnd + -- * Extracting lists of values from 'Counts' + , fstElems + , sndElems ) where import qualified Data.Foldable as F +import qualified Data.Traversable as T import Data.Monoid import Data.List hiding (sum) import qualified Data.Set as Set import qualified Data.Map as Map import Prelude hiding (sum) +import NLP.Scores.Internals + -- | Accuracy: the proportion of elements in the first sequence equal -- to elements at corresponding positions in second -- sequence. Sequences should be of equal lengths. -accuracy :: (Eq a, Fractional c, F.Foldable t) => t a -> t a -> c -accuracy xs = mean . map fromEnum . zipWith (==) (F.toList xs) . F.toList +accuracy :: (Eq a, Fractional c, T.Traversable t, F.Foldable s) => t a -> s a -> c +accuracy xs = mean . fmap fromEnum . zipWithTF (==) xs . F.toList {-# SPECIALIZE accuracy :: [Double] -> [Double] -> Double #-} -- | Reciprocal rank: the reciprocal of the rank at which the first arguments @@ -86,7 +100,7 @@ -- | Variation of information: VI(X,Y) = H(X) + H(Y) - 2 MI(X,Y) vi :: (Ord a, Ord b) => Counts a b -> Double -vi cs@(Counts cxy cx cy) = entropy (elems cx) + entropy (elems cy) - 2 * mi cs +vi cs@(Counts _ cx cy) = entropy (elems cx) + entropy (elems cy) - 2 * mi cs where elems = Map.elems -- | Adjusted Rand Index: @@ -98,21 +112,6 @@ sum2 = sum [ choice ni 2 | ni <- Map.elems cx ] sum3 = sum [ choice nj 2 | nj <- Map.elems cy ] --- | A count -type Count = Double --- | Count table -data Counts a b = - Counts - { joint :: !(Map.Map (P a b) Count) -- ^ Counts of both components - , marginalFst :: !(Map.Map a Count) -- ^ Counts of the first component - , marginalSnd :: !(Map.Map b Count) -- ^ Counts of the second component - } -data P a b = P !a !b deriving (Eq, Ord) - --- | The empty count table -empty :: (Ord a, Ord b) => Counts a b -empty = Counts Map.empty Map.empty Map.empty - -- | The sum of a sequence of numbers sum :: (F.Foldable t, Num a) => t a -> a sum = F.foldl' (+) 0 @@ -141,17 +140,54 @@ fromIntegral (Set.size (Set.union a b)) {-# SPECIALIZE jaccard :: (Ord a) => Set.Set a -> Set.Set a -> Double #-} --- | Entropy: H(X) = -SUM_i P(X=i) log_2(P(X=i)) +-- | Entropy: H(X) = -SUM_i P(X=i) log_2(P(X=i)). @entropy xs@ is the +-- entropy of the random variable represented by the sequence @xs@, +-- where each element of @xs@ is the count of the one particular +-- value the random variable can take. If you need to compute the +-- entropy from a sequence of outcomes, the following will work: +-- +-- > entropy . elems . histogram +-- entropy :: (Floating c, F.Foldable t) => t c -> c entropy cx = negate . getSum . F.foldMap (Sum . f) $ cx where n = sum cx logn = logBase 2 n f nx = nx / n * (logBase 2 nx - logn) +-- | @histogram xs@ is returns the map of the frequency counts of the +-- elements in sequence @xs@ +histogram :: (Num a, Ord k, F.Foldable t) => t k -> Map.Map k a +histogram = F.foldl' (\ z k -> Map.insertWith' (+) k 1 z) Map.empty + -- | Creates count table 'Counts' -counts :: (Ord a, Ord b, F.Foldable t) => t (a, b) -> Counts a b -counts xys = F.foldl' f empty xys - where f cs@(Counts cxy cx cy) (!x,!y) = - cs { joint = Map.insertWith' (+) (P x y) 1 cxy +counts :: (Ord a, Ord b, T.Traversable t, F.Foldable s) => t a -> s b -> Counts a b +counts xs = F.foldl' f empty . zipWithTF P xs . F.toList + where f cs@(Counts cxy cx cy) p@(P x y) = + cs { joint = Map.insertWith' (+) p 1 cxy , marginalFst = Map.insertWith' (+) x 1 cx , marginalSnd = Map.insertWith' (+) y 1 cy } + +-- | Joint count +countJoint :: (Ord a, Ord b) => a -> b -> Counts a b -> Count +countJoint x y = Map.findWithDefault 0 (P x y) . joint +-- | Count of first element +countFst :: Ord k => k -> Counts k b -> Count +countFst x = Map.findWithDefault 0 x . marginalFst +-- | Count of second element +countSnd :: Ord k => k -> Counts a k -> Count +countSnd y = Map.findWithDefault 0 y . marginalSnd + +-- | List of values of first element +fstElems :: Counts k b -> [k] +fstElems = Map.keys . marginalFst +-- | List of values of second element +sndElems :: Counts a k -> [k] +sndElems = Map.keys . marginalSnd + +-- | @zipWithTF h t f@ zips the values from the traversable @t@ with +-- the values from the foldable @f@ using the function @h@. +zipWithTF :: (T.Traversable t, F.Foldable f) => + (a -> b -> c) -> t a -> f b -> t c +zipWithTF h t f = snd . T.mapAccumL map_one (F.toList f) $ t + where map_one (x:xs) y = (xs, h y x) + diff --git a/NLP/Scores/Internals.hs b/NLP/Scores/Internals.hs new file mode 100644 --- /dev/null +++ b/NLP/Scores/Internals.hs @@ -0,0 +1,39 @@ +module NLP.Scores.Internals + ( Counts(..) + , Count + , P(..) + , empty + , unionPlus + ) +where +import qualified Data.Map as Map +import Data.Monoid + +-- | A count +type Count = Double +-- | Count table +data Counts a b = + Counts + { joint :: !(Map.Map (P a b) Count) -- ^ Counts of both components + , marginalFst :: !(Map.Map a Count) -- ^ Counts of the first component + , marginalSnd :: !(Map.Map b Count) -- ^ Counts of the second component + } +data P a b = P !a !b deriving (Eq, Ord) + +-- | The empty count table +empty :: (Ord a, Ord b) => Counts a b +empty = Counts Map.empty Map.empty Map.empty + +instance (Ord a, Ord b) => Monoid (Counts a b) where + mempty = empty + c `mappend` k = + Counts { joint = unionPlus (joint c) (joint k) + , marginalFst = unionPlus (marginalFst c) (marginalFst k) + , marginalSnd = unionPlus (marginalSnd c) (marginalSnd k) + } + +unionPlus :: (Num a, Ord k) => Map.Map k a -> Map.Map k a -> Map.Map k a +unionPlus m = + Map.foldlWithKey' (\z k v -> Map.insertWith' (+) k v z) m +{-# SPECIALIZE unionPlus :: (Ord k) => + Map.Map k Count -> Map.Map k Count -> Map.Map k Count #-} diff --git a/nlp-scores.cabal b/nlp-scores.cabal --- a/nlp-scores.cabal +++ b/nlp-scores.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.4.0 +Version: 0.5.2 -- A short (one-line) description of the package. Synopsis: Scoring functions commonly used for evaluation in NLP and IR @@ -48,7 +48,7 @@ Library -- Modules exported by the library. - Exposed-modules: NLP.Scores + Exposed-modules: NLP.Scores, NLP.Scores.Internals -- Packages needed in order to build this package. Build-depends: base >= 3 && < 5 , containers >= 0.4.2