diff --git a/NLP/Scores.hs b/NLP/Scores.hs --- a/NLP/Scores.hs +++ b/NLP/Scores.hs @@ -19,13 +19,16 @@ module NLP.Scores ( -- * Scores for classification and ranking - accuracy + errorRate + , accuracy , recipRank , avgPrecision -- * Scores for clustering , ari , mi , vi + -- * Strength of association + , logLikelihoodRatio -- * Comparing probability distributions , kullbackLeibler , jensenShannon @@ -42,7 +45,8 @@ , countJoint , countFst , countSnd - -- * Extracting lists of values from 'Counts' + , countTotal + -- * Extracting lists of values from 'Counts' , fstElems , sndElems ) @@ -54,9 +58,17 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Prelude hiding (sum) - +import Data.Strict.Tuple (Pair((:!:))) import NLP.Scores.Internals + +-- | Error rate: the proportion of elements in the first sequence NOT +-- equal to elements at corresponding positions in second +-- sequence. Sequences should be of equal lengths. +errorRate :: (Eq a, Fractional c, T.Traversable t, F.Foldable s) => t a -> s a -> c +errorRate xs ys = 1 - accuracy xs ys +{-# SPECIALIZE errorRate :: [Double] -> [Double] -> Double #-} + -- | Accuracy: the proportion of elements in the first sequence equal -- to elements at corresponding positions in second -- sequence. Sequences should be of equal lengths. @@ -95,18 +107,37 @@ 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 = + cell (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 ] + in sum [ cell (x :!: y) nxy | (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 _ cx cy) = entropy (elems cx) + entropy (elems cy) - 2 * mi cs where elems = Map.elems --- | Kullback-Leibler divergence: KL(X,Y) = SUM_i P(X=i) log_2(P(X=i)/P(Y=i)). + +-- | Log-likelihood ratio for two binomial distributions. +-- H_0: P(x|y) = p = P(x|~y) +-- H_1: P(x|y) = p1 =/= p2 = P(x|~y) +logLikelihoodRatio :: (Ord a, Ord b) => Counts a b -> a -> b -> Double +logLikelihoodRatio cs x y = + let p = nx / n -- relative count of x + p1 = nxy / ny -- relative count of xy among _y + p2 = (nx - nxy) / (n - ny) -- relative count of xnoty among noty + n = countTotal cs + nx = countFst x cs + ny = countSnd y cs + nxy = countJoint x y cs + b k n p = p**k * (1-p)**(n-k) + {-# INLINE b #-} + in log (b nxy nx p) + log (b (nx - nxy) (n - ny) p) + - log (b nxy nx p1) - log (b (nx - nxy) (n - ny) p2) + + +-- | Kullback-Leibler divergence: KL(X,Y) = SUM_i P(X=i) log_2(P(X=i)\/P(Y=i)). -- The distributions can be unnormalized. kullbackLeibler :: (Eq a, Floating a, F.Foldable f, T.Traversable t) => t a -> f a -> a @@ -118,11 +149,13 @@ mult w p = w * p {-# INLINE mult #-} --- | Jensen-Shannon divergence: JS(X,Y) = 1/2 KL(X,(X+Y)/2) + 1/2 KL(Y,(X+Y)/2). +-- | Jensen-Shannon divergence: JS(X,Y) = 1\/2 KL(X,(X+Y)\/2) + 1\/2 KL(Y,(X+Y)\/2). -- The distributions can be unnormalized. jensenShannon :: (Eq a, Floating a, T.Traversable t, T.Traversable u) => t a -> u a -> a -jensenShannon xs ys = 0.5 * kullbackLeibler xs zs + 0.5 * kullbackLeibler ys zs - where zs = zipWithTF (+) xs ys +jensenShannon xs ys = 0.5 * kullbackLeibler xs' zs + 0.5 * kullbackLeibler ys' zs + where zs = zipWithTF (+) xs' ys' + xs' = normalize xs + ys' = normalize ys -- | Adjusted Rand Index: ari :: (Ord a, Ord b) => Counts a b -> Double @@ -141,11 +174,11 @@ -- | The mean of a sequence of numbers. mean :: (F.Foldable t, Fractional n, Real a) => t a -> n mean xs = - let (P tot len) = F.foldl' (\(P s l) x -> (P (s+x) (l+1))) (P 0 0) xs + let (tot :!: len) = F.foldl' (\(s :!: l) x -> ((s+x) :!: (l+1))) (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 +-- | 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 #-} @@ -180,21 +213,24 @@ -- | Creates count table 'Counts' 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) = +counts xs = F.foldl' f empty . zipWithTF (:!:) xs . F.toList + where f cs@(Counts cxy cx cy) 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 +countJoint x y = Map.findWithDefault 0 (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 +-- | Total element count +countTotal :: Counts a k -> Count +countTotal = F.sum . joint -- | List of values of first element fstElems :: Counts k b -> [k] @@ -210,3 +246,6 @@ zipWithTF h t f = snd . T.mapAccumL map_one (F.toList f) $ t where map_one (x:xs) y = (xs, h y x) +-- | @normalize xs@ divides each element of xs by the sum of xs. +normalize :: (Fractional b, Functor f, F.Foldable f) => f b -> f b +normalize xs = let s = sum xs in fmap (/s) xs diff --git a/NLP/Scores/Internals.hs b/NLP/Scores/Internals.hs --- a/NLP/Scores/Internals.hs +++ b/NLP/Scores/Internals.hs @@ -1,25 +1,24 @@ module NLP.Scores.Internals ( Counts(..) , Count - , P(..) , empty , unionPlus ) where import qualified Data.Map as Map import Data.Monoid +import Data.Strict.Tuple -- | A count type Count = Double -- | Count table data Counts a b = Counts - { joint :: !(Map.Map (P a b) Count) -- ^ Counts of both components + { joint :: !(Map.Map (Pair 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 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.5.4 +Version: 0.7.0 -- A short (one-line) description of the package. Synopsis: Scoring functions commonly used for evaluation in NLP and IR @@ -29,7 +29,7 @@ -- An email address to which users can send suggestions, bug reports, -- and patches. -Maintainer: gchrupala@lsv.uni-saarland.de +Maintainer: grzegorz.chrupala@gmail.com -- A copyright notice. -- Copyright: @@ -51,7 +51,7 @@ Exposed-modules: NLP.Scores, NLP.Scores.Internals -- Packages needed in order to build this package. - Build-depends: base >= 3 && < 5 , containers >= 0.4.2 + Build-depends: base >= 3 && < 5 , containers >= 0.4.2 , strict >= 0.3 -- Modules not exported by this package. -- Other-modules: