diff --git a/NLP/Probability/Chain.hs b/NLP/Probability/Chain.hs new file mode 100644 --- /dev/null +++ b/NLP/Probability/Chain.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeSynonymInstances, TypeSynonymInstances, TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving, UndecidableInstances, TemplateHaskell, MultiParamTypeClasses, BangPatterns, StandaloneDeriving #-} +module NLP.Probability.Chain (simpleObserve, + JointModel (..) + -- M2(..), M3(..), M4(..), M5(..), M7(..), HolderPretty, holderPretty, hPretty + ) where +import NLP.Probability.ConditionalDistribution +import NLP.Probability.Distribution +import NLP.Probability.Observation +import qualified Data.Map as M + + + +class JointModel a where + data FullEvent a + data FullContext a + data Probs a + data Observation a + data Pairs a + chainRule :: FullEvent a -> FullContext a -> Pairs a + observe :: Pairs a -> Observation a + prob :: Probs a -> Pairs a -> Prob + estimate :: Observation a -> Probs a + +class Estimate a where + type Dist a + +instance Event String where type EventMap String = M.Map +instance Event Int where type EventMap Int = M.Map + +simpleObserve a b = observe $ chainRule a b diff --git a/NLP/Probability/ConditionalDistribution.hs b/NLP/Probability/ConditionalDistribution.hs --- a/NLP/Probability/ConditionalDistribution.hs +++ b/NLP/Probability/ConditionalDistribution.hs @@ -6,11 +6,15 @@ CondObserved(), CondDistribution, condObservation, + condObservations, + condObservationCounts, Context(..), estimateGeneralLinear, Weighting, wittenBell, - simpleLinear + simpleLinear, + DebugDist, + mkDist ) where import qualified Data.ListTrie.Base.Map as M import Data.List (inits) @@ -19,7 +23,7 @@ import NLP.Probability.Distribution import NLP.Probability.Observation import Data.Binary - +import Text.PrettyPrint.HughesPJClass -- $CondDistDesc -- Say we want to estimate a conditional distribution based on a very large set of observed data. -- Naively, we could just collect all the data and estimate a large table, but @@ -40,9 +44,12 @@ -- + + -- | The set of observations of event conditioned on context. event must be an instance of Event and context of Context type CondObserved event context = (ST.SmoothTrie (SubMap context) (Sub context) (Counts event)) + -- | Events are conditioned on Contexts. When Contexts are sparse, we need a way to decompose into simpler SubContexts. -- This class allows us to separate this decomposition from the collection of larger contexts. class (M.Map (SubMap a) (Sub a)) => Context a where @@ -50,22 +57,35 @@ type Sub a -- | A map over subcontexts (for efficiency) type SubMap a :: * -> * -> * + -- | A function to enumerate subcontexts of a context decompose :: a -> [Sub a] + -- | A CondObserved set for a single event and context. -condObservation :: (Context context, Event event) => - event -> context -> CondObserved event context -condObservation event context = +condObservations :: (Context context, Event event) => + event -> context -> Count -> CondObserved event context +condObservations event context count = ST.addColumn decomp observed mempty - where observed = observation event + where observed = observations event count decomp = decompose context -type CondDistribution event context = context -> Distribution event +condObservation event context = condObservations event context 1.0 +condObservationCounts :: (Context context, Event event) => + context -> Counts event -> CondObserved event context +condObservationCounts context counts = + ST.addColumn decomp counts mempty + where decomp = decompose context + +type CondDistribution event context = context -> Distribution event +type DebugDist event context =(context -> event -> [(Double,Double)]) + type Weighting = forall a. [Maybe (Observed a)] -> [Double] +mkDist :: DebugDist event context -> CondDistribution event context +mkDist dd context event = sum $ map (uncurry (*)) $ dd context event -- | General Linear Interpolation. Produces a Conditional Distribution from observations. -- It requires a GeneralLambda function which tells it how to weight each level of smoothing. @@ -76,10 +96,10 @@ estimateGeneralLinear :: (Event event, Context context) => Weighting -> CondObserved event context -> - CondDistribution event context + DebugDist event context estimateGeneralLinear genLambda cstat = conFun where - conFun context = (\event -> sum $ zipWith (*) lambdas $ map (probE event) stats) + conFun context = (\event -> zip lambdas $ map (probE event) stats) where stats = reverse $ Nothing : (map (\k -> Just $ ST.lookupWithDefault (finish mempty) k cstat') $ tail $ inits $ decompose context) @@ -110,4 +130,5 @@ if total cur > 0 then (l*mult : wittenBell' ls ((1-l)*mult)) else (0.0: wittenBell' ls mult) where l = lambdaWBC n cur + diff --git a/NLP/Probability/EM.hs b/NLP/Probability/EM.hs new file mode 100644 --- /dev/null +++ b/NLP/Probability/EM.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module NLP.Probability.EM where +import NLP.Probability.Observation +import NLP.Probability.ConditionalDistribution +import Control.Monad.Random +import Control.Monad (liftM) +import Data.Monoid + +randomCounts :: (Bounded event, Enum event, Event event, MonadRandom mr) => + mr (Counts event) +randomCounts = do + rcounts <- mapM (\e -> do {r <- getRandomR (1, 10); return (e,r)}) [minBound..maxBound] + return $ mconcat $ map (uncurry observations) rcounts + +randomCondCounts :: (Bounded event, Enum event , Event event , + Bounded context, Enum context, Context context, + MonadRandom mr) => [context] -> mr (CondObserved event context) +randomCondCounts contexts = do + let r = randomCounts + condcounts <- mapM (\context -> condObservationCounts context `liftM` r) contexts + return $ mconcat condcounts + diff --git a/NLP/Probability/Example/Trigram.hs b/NLP/Probability/Example/Trigram.hs --- a/NLP/Probability/Example/Trigram.hs +++ b/NLP/Probability/Example/Trigram.hs @@ -30,7 +30,7 @@ languageModel :: String -> CondDistribution Word TrigramContext languageModel sentences = - estimateGeneralLinear (wittenBell 5) $ -- (simpleLinear [0.7, 0.3, 0.0]) $ + mkDist $ estimateGeneralLinear (wittenBell 5) $ -- (simpleLinear [0.7, 0.3, 0.0]) $ mconcat $ map makeTrigrams $ T.split "." $ T.pack sentences prob lm (w1, w2, w3) = diff --git a/NLP/Probability/Observation.hs b/NLP/Probability/Observation.hs --- a/NLP/Probability/Observation.hs +++ b/NLP/Probability/Observation.hs @@ -7,10 +7,11 @@ Counts, Event(..), observation, + observations, inc, Observed(..), - finish - + finish, + showObsPretty ) where import Data.Monoid @@ -19,7 +20,7 @@ import Data.Binary import Text.PrettyPrint.HughesPJClass import qualified Data.ListTrie.Base.Map as M - +import Control.DeepSeq -- $ObsDesc -- This module provides a simple way to collect observations ('counts'), particularly within a monoid. -- Use 'observation' for each observed event and 'mappend' for combining observations. Finally 'finish' before estimating probabilities. @@ -31,16 +32,26 @@ counts :: (EventMap event) event Count } + + -- | Trivial type family for events. Just use EventMap = M.Map for most cases. Allows clients to specify the type of map used, when efficiency is important. class (M.Map (EventMap event) event) => Event event where type EventMap event :: * -> * -> * -instance (Event event, Show event) => Pretty (Counts event) where - pPrint (Counts counts) = - vcat $ map (\(e,count) -> (text $ show $ e) <+> equals <+> double count ) $ M.toList counts +pShow fn (Counts counts) = vcat $ map (\(e,count) -> (fn e) <+> equals <+> double count ) $ M.toList counts +showObsPretty :: (Event event, Monad m) => (event -> m Doc) -> Counts event -> m Doc +showObsPretty fn mcounts = do + res <- mapM (\(e,count) -> do + me <- (fn e) + return (me <+> equals <+> double count) ) $ M.toList $ counts mcounts + return $ vcat res + +instance (Event event, Pretty event) => Pretty (Counts event) where + pPrint = pShow pPrint + instance (Event event, Show event) => (Show (Counts event)) where - show = render . pPrint + show = render . pShow (text. show) instance (Event event) => Monoid (Counts event) where mempty = Counts M.empty @@ -51,9 +62,14 @@ put (Counts m) = put m get = Counts `liftM` get +instance (Event event, NFData event) => NFData (Counts event) where + rnf = rnf . M.toList . counts + -- | Observation of a single event observation :: (Event event) => event -> Counts event -observation event = Counts (M.singleton event 1) +observation event = observations event 1.0 + +observations event count = Counts (M.singleton event count) -- | Manually increment the count of an event inc :: (Event e) => Counts e -> e -> Count -> Counts e diff --git a/NLP/Probability/SmoothTrie.hs b/NLP/Probability/SmoothTrie.hs --- a/NLP/Probability/SmoothTrie.hs +++ b/NLP/Probability/SmoothTrie.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} module NLP.Probability.SmoothTrie where import Data.Monoid import qualified Data.ListTrie.Map as T @@ -10,11 +10,14 @@ import Data.Binary import Text.PrettyPrint.HughesPJClass import qualified Data.ListTrie.Base.Map as M - +import Control.DeepSeq newtype SmoothTrie map letter holder= SmoothTrie (T.TrieMap map letter holder) deriving (Show, Binary, Functor) +instance (NFData letter, NFData holder, M.Map map letter) => NFData (SmoothTrie map letter holder) where + rnf (SmoothTrie st) = rnf $ T.toList st + instance (M.Map map letter, Arbitrary letter, Arbitrary holder) => Arbitrary (SmoothTrie map letter holder) where arbitrary = do holder <- arbitrary @@ -34,6 +37,18 @@ mempty = SmoothTrie mempty mappend (SmoothTrie m) (SmoothTrie m') = SmoothTrie (T.unionWith mappend m m') mconcat sumtries = SmoothTrie $ T.unionsWith mappend $ [s | SmoothTrie s <-sumtries] + +mPretty showEvent showCond (SmoothTrie t) = printRows 1 + where + tlist = T.toList t + printRows n = if null oflen then return $ empty + else do + ofls <- mapM (\(k,v) -> do {pk<-showCond k; pv <- showEvent v; return (pk,pv) }) oflen + pr <- printRows (n + 1) + return (hang (text "Row " <> int n) 4 + $ (vcat $ map (\(k,v) -> k <+>v) ofls) $$ pr) + where oflen = filter ((== n).length.fst) tlist + lookup ks (SmoothTrie t) = T.lookup ks t diff --git a/estimators.cabal b/estimators.cabal --- a/estimators.cabal +++ b/estimators.cabal @@ -1,5 +1,5 @@ name: estimators -version: 0.1.1 +version: 0.1.4 synopsis: Tool for managing probability estimation description: This library provides data structures for collecting counts and estimating distributions from observed data. It is designed for natural language @@ -14,20 +14,24 @@ cabal-version: >= 1.2 library + ghc-options: -O2 exposed-modules: NLP.Probability.Distribution NLP.Probability.Observation NLP.Probability.ConditionalDistribution + NLP.Probability.EM NLP.Probability.Example.Trigram - - other-modules: NLP.Probability.SmoothTrie - + NLP.Probability.Chain, + NLP.Probability.SmoothTrie build-Depends: base >= 3 && < 4, containers >= 0.1 && < 0.3, binary, list-tries, pretty, prettyclass, - text - + text, + deepseq, + MonadRandom, + QuickCheck >= 2.0, + mtl