diff --git a/NLP/Scores.hs b/NLP/Scores.hs --- a/NLP/Scores.hs +++ b/NLP/Scores.hs @@ -1,42 +1,53 @@ {-# LANGUAGE BangPatterns #-} +-- | Scoring functions commonly used for evaluation of NLP +-- systems. Most functions in this module work on lists, but some take +-- a precomputed table of 'Counts'. This will give a speedup if you +-- want to compute multiple scores on the same data. For example to +-- compute the Mutual Information, Variation of Information and the +-- Adujusted Rand Index on the same pair of clusterings: +-- +-- >>> let cs = counts $ zip "abcabc" "abaaba" +-- >>> mapM_ (print . ($ cs)) [mi, ari, vi] +-- module NLP.Scores ( - sum - , mean - , accuracy + -- * Scores for classification and ranking + accuracy , recipRank , avgPrecision + -- * Scores for clustering + , ari + , mi + , vi + -- * Auxiliary types and functions + , Count + , Counts + , sum + , mean , jaccard + , entropy ) where import Data.List hiding (sum) import qualified Data.Set as Set +import qualified Data.Map as Map import Prelude hiding (sum) --- | The sum of a list of numbers (without overflowing stack, --- unlike 'Prelude.sum'). -sum :: (Num a) => [a] -> a -sum = foldl' (+) 0 - --- | The mean of a list of numbers. -mean :: (Fractional n, Real a) => [a] -> n -mean xs = - let (sum,len) = foldl' (\(!s,!l) x -> (s+x,l+1)) (0,0) xs - in realToFrac sum/len - -- | Accuracy: the proportion of elements in the first list equal to -- elements at corresponding positions in second list. Lists should be -- of equal lengths. accuracy :: (Eq a, Fractional n) => [a] -> [a] -> n accuracy xs = mean . map fromEnum . zipWith (==) xs - +{-# SPECIALIZE accuracy :: [Double] -> [Double] -> Double #-} + -- | Reciprocal rank: the reciprocal of the rank at which the first arguments -- occurs in the list given as the second argument. recipRank :: (Eq a, Fractional n) => a -> [a] -> n recipRank y ys = - case [ r | (r,y') <- zip [1..] ys , y' == y ] of + case [ r | (r,y') <- zip [1::Int ..] ys , y' == y ] of [] -> 0 r:_ -> 1/fromIntegral r +{-# SPECIALIZE recipRank :: Double -> [Double] -> Double #-} -- | Average precision. -- @@ -51,8 +62,69 @@ . takeWhile (\(_,_,cum) -> cum <= Set.size gold) . snd . mapAccumL (\z (r,rel) -> (z+rel,(r,rel,z+rel))) 0 - $ [ (r,fromEnum $ x `Set.member` gold) | (x,r) <- zip xs [1..]] + $ [ (r,fromEnum $ x `Set.member` gold) | (x,r) <- zip xs [1::Int ..]] +{-# SPECIALIZE avgPrecision :: (Ord a) => Set.Set a -> [a] -> Double #-} +-- | Mutual information: MI(X,Y) = H(X) - H(X|Y) = H(Y) - H(Y|X). Also +-- known as information gain. +mi :: (Ord a, Ord b) => Counts a b -> Double +mi (Counts cxy cx cy) = + let n = Map.foldl' (+) 0 cxy + cell (P x y) nxy = + let nx = cx Map.! x + ny = cy Map.! y + in nxy / n * logBase 2 (nxy * n / nx / ny) + in sum [ cell (P x y) nxy | (P x y, nxy) <- Map.toList cxy ] + +-- | 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 + where elems = Map.elems + +-- | Adjusted Rand Index: +ari :: (Ord a, Ord b) => Counts a b -> Double +ari (Counts cxy cx cy) = (sum1 - sum2*sum3/choicen2) + / (1/2 * (sum2+sum3) - (sum2*sum3) / choicen2) + where choicen2 = choice (sum . Map.elems $ cx) 2 + sum1 = sum [ choice nij 2 | nij <- Map.elems cxy ] + 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 list of numbers (without overflowing stack, +-- unlike 'Prelude.sum'). +sum :: (Num a) => [a] -> a +sum = foldl' (+) 0 +{-# SPECIALIZE sum :: [Double] -> Double #-} +{-# SPECIALIZE sum :: [Int] -> Int #-} +{-# INLINE sum #-} + +-- | The mean of a list of numbers. +mean :: (Fractional n, Real a) => [a] -> n +mean xs = + let (P tot len) = foldl' (\(P s l) x -> (P (s+x) (l+1))) (P 0 0) xs + in realToFrac tot/len +{-# SPECIALIZE mean :: [Double] -> Double #-} + +-- | The binomial coefficient: C^n_k = PROD^k_i=1 (n-k-i)/i +choice :: (Enum b, Fractional b) => b -> b -> b +choice n k = foldl' (*) 1 [n-k+1 .. n] / foldl' (*) 1 [1 .. k] +{-# SPECIALIZE choice :: Double -> Double -> Double #-} + -- | Jaccard coefficient -- J(A,B) = |AB| / |A union B| jaccard :: (Fractional n, Ord a) => Set.Set a -> Set.Set a -> n @@ -60,4 +132,19 @@ fromIntegral (Set.size (Set.intersection a b)) / 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 :: [Count] -> Double +entropy cx = negate $ sum [ f nx | nx <- cx ] + where n = sum cx + logn = logBase 2 n + f nx = nx / n * (logBase 2 nx - logn) + +counts :: (Ord a, Ord b) => [(a,b)] -> Counts a b +counts xys = foldl' f empty xys + where f cs@(Counts cxy cx cy) (!x,!y) = + cs { joint = Map.insertWith' (+) (P x y) 1 cxy + , marginalFst = Map.insertWith' (+) x 1 cx + , marginalSnd = Map.insertWith' (+) y 1 cy } + 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.2.1 +Version: 0.2.2 -- A short (one-line) description of the package. Synopsis: Scoring functions commonly used for evaluation in NLP and IR @@ -51,8 +51,7 @@ Exposed-modules: NLP.Scores -- Packages needed in order to build this package. - Build-depends: base >= 3 && < 5 , containers >= 0.4 - + Build-depends: base >= 3 && < 5 , containers >= 0.4.2 -- Modules not exported by this package. -- Other-modules: