diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2008, University of Brighton +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the University of Brighton nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/NLP/Probability/ConditionalDistribution.hs b/NLP/Probability/ConditionalDistribution.hs new file mode 100644 --- /dev/null +++ b/NLP/Probability/ConditionalDistribution.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, Rank2Types, FlexibleContexts #-} +module NLP.Probability.ConditionalDistribution ( + -- * Conditional Distributions + -- + -- $CondDistDesc + CondObserved(), + CondDistribution, + condObservation, + Context(..), + estimateGeneralLinear, + Weighting, + wittenBell, + simpleLinear + ) where +import qualified Data.ListTrie.Base.Map as M +import Data.List (inits) +import Data.Monoid +import qualified NLP.Probability.SmoothTrie as ST +import NLP.Probability.Distribution +import NLP.Probability.Observation +import Data.Binary + +-- $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 +-- our table would have little or no counts for a feasible future observations. +-- +-- In practice, we use smoothing to supplement rare contexts with data from similar, more often seen contexts. For instance, +-- using bigram probabilities when the given trigrams observations are too sparse. +-- Most of these smoothing techniques are special cases of general linear interpolation, which chooses the weight of +-- each level of smoothing based on the sparsity of the current context. +-- +-- In this module, we give an implementation of this process that separates out count collection +-- from the smoothing model, using a Trie. The user specifies a Context instance that relates the full conditional context +-- to a sequences of SubContexts that characterize the levels of smoothing and the transitions in the Trie. We also give a small set of smoothing techniques +-- to combine these levels. +-- +-- This work is based on Chapter 6 of ''Foundations of Statistical Natural Language Processing'' +-- by Chris Manning and Hinrich Schutze. +-- + + +-- | 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 + -- | The type of sub contexts + 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 = + ST.addColumn decomp observed mempty + where observed = observation event + decomp = decompose context + +type CondDistribution event context = context -> Distribution event + + +type Weighting = forall a. [Maybe (Observed a)] -> [Double] + + +-- | General Linear Interpolation. Produces a Conditional Distribution from observations. +-- It requires a GeneralLambda function which tells it how to weight each level of smoothing. +-- The GeneralLambda function can observe the counts of each level of context. +-- +-- Note: We include a final level of backoff where everything is given an epsilon likelihood. To +-- ignore this, just give it lambda = 0. +estimateGeneralLinear :: (Event event, Context context) => + Weighting -> + CondObserved event context -> + CondDistribution event context +estimateGeneralLinear genLambda cstat = conFun + where + conFun context = (\event -> sum $ zipWith (*) lambdas $ map (probE event) stats) + where stats = reverse $ + Nothing : (map (\k -> Just $ ST.lookupWithDefault (finish mempty) k cstat') $ + tail $ inits $ decompose context) + probE event (Just dist) = if isNaN p then 0.0 else p + where p = mle dist event + probE event Nothing = 1e-19 + lambdas = genLambda stats + cstat' = fmap finish cstat + +-- | Weight each level by a fixed predefined amount. +simpleLinear :: [Double] -> Weighting +simpleLinear lambdas = const lambdas + + +lambdaWBC :: Int -> Observed b -> Double +lambdaWBC n eobs = total' / (((fromIntegral n) * distinct) + total') + where total' = total eobs + distinct = unique eobs + +-- | Weight each level by the likelihood that a new event will be seen at that level. +-- t / ((n * d) + t) where t is the total count, d is the number of distinct observations, +-- and n is a user defined constant. +wittenBell :: Int -> Weighting +wittenBell n ls = wittenBell' ls 1.0 + where + wittenBell' [Nothing] mult = [mult] + wittenBell' (Just cur:ls) mult = + 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/Distribution.hs b/NLP/Probability/Distribution.hs new file mode 100644 --- /dev/null +++ b/NLP/Probability/Distribution.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +module NLP.Probability.Distribution ( + -- * Distributions + -- + -- $DistDesc + Prob, Distribution, mle, laplace) where +import qualified Data.ListTrie.Base.Map as M +import Data.Maybe (fromMaybe) +import NLP.Probability.Observation + +-- $DistDesc +-- Some very simple ways of estimating probabilities from observations. Will expand in the future. + +type Prob = Double + +type Distribution event = event -> Prob + +type Estimator event = Observed event -> Distribution event + +-- | Maximum Likelihood Estimation gives out probability by normalizing over observed events. +-- Unseen events are gived zero probabilty. +mle :: (Event event) => Estimator event +mle obs e = (fromMaybe 0.0 $ M.lookup e $ observed obs) / (total obs) + +laplace :: (Event event) => (Double, Double) -> Estimator event +laplace (b, lambda) obs e = (count + lambda) / (n + (b * lambda)) + where + count = fromMaybe 0.0 $ M.lookup e $ observed obs + n = total obs + diff --git a/NLP/Probability/Example/Trigram.hs b/NLP/Probability/Example/Trigram.hs new file mode 100644 --- /dev/null +++ b/NLP/Probability/Example/Trigram.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TypeFamilies, OverloadedStrings #-} +module NLP.Probability.Example.Trigram ( + -- * Source for a trigram language modeling + +) where +import qualified Data.Text as T +import qualified Data.Map as M +import Data.Monoid +import NLP.Probability.ConditionalDistribution +import NLP.Probability.Observation + +newtype Word = Word T.Text + deriving (Ord, Eq) + +newtype TrigramContext = Trigram (Word, Word) + +instance Event Word where type EventMap Word = M.Map + +instance Context TrigramContext where + type Sub TrigramContext = Word + type SubMap TrigramContext = M.Map + decompose (Trigram (w1, w2)) = [w1, w2] + +makeTrigrams :: T.Text -> CondObserved Word TrigramContext +makeTrigrams sentence = + mconcat $ map (uncurry condObservation) $ take3 $ map Word words + where words = ["*S1*", "*S2*"] ++ (T.split " " sentence) ++ ["*E1*", "*E2*"] + take3 [_,_] = [] + take3 (a:b:c:rest) = (c, Trigram (a, b)):(take3 (b:c:rest)) + +languageModel :: String -> CondDistribution Word TrigramContext +languageModel sentences = + estimateGeneralLinear (wittenBell 5) $ -- (simpleLinear [0.7, 0.3, 0.0]) $ + mconcat $ map makeTrigrams $ T.split "." $ T.pack sentences + +prob lm (w1, w2, w3) = + lm (Trigram (Word $ T.pack w1, Word $ T.pack w2)) $ Word $ T.pack w3 diff --git a/NLP/Probability/Observation.hs b/NLP/Probability/Observation.hs new file mode 100644 --- /dev/null +++ b/NLP/Probability/Observation.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleContexts, UndecidableInstances #-} +module NLP.Probability.Observation ( + -- * Observation + -- + -- $ObsDesc + Count, + Counts, + Event(..), + observation, + inc, + Observed(..), + finish + + + ) where +import Data.Monoid +import Data.List (intercalate) +import Control.Monad (liftM) +import Data.Binary +import Text.PrettyPrint.HughesPJClass +import qualified Data.ListTrie.Base.Map as M + +-- $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. + +type Count = Double + +-- | Observations over a set of events. The param event must be an instance of class Event +newtype Counts event = Counts { + 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 + +instance (Event event, Show event) => (Show (Counts event)) where + show = render . pPrint + +instance (Event event) => Monoid (Counts event) where + mempty = Counts M.empty + mappend (Counts a) (Counts b) = Counts $ M.unionWith (+) a b + +instance (Event event, Binary event, Binary ((EventMap event) event Count)) => + Binary (Counts event) where + put (Counts m) = put m + get = Counts `liftM` get + +-- | Observation of a single event +observation :: (Event event) => event -> Counts event +observation event = Counts (M.singleton event 1) + +-- | Manually increment the count of an event +inc :: (Event e) => Counts e -> e -> Count -> Counts e +inc obs e c = obs {counts = M.insertWith (+) e c $ counts obs} + +observedEvents :: (Event event) => Counts event -> [event] +observedEvents (Counts m) = map fst $ filter ((> 0) . snd) $ M.toList m + +elems :: (M.Map map event) => map event elem -> [elem] +elems = map snd . M.toList + +calcTotal :: (Event event) => Counts event -> Count +calcTotal = sum . elems .counts + +countNonTrivial :: (Event event ) => Counts event -> Count +countNonTrivial = fromIntegral .length . filter (>0) . elems . counts + +data Observed event = Observed { + observed :: (EventMap event) event Count, + total :: Double -- ^ Gives the total number of observations sum_a C(a) + , unique :: Count -- ^ Gives the total number of events observed at least once {a | C(a) > 1} +} + +-- | Finish a set of offline observations so that they can be used to estimate +-- likelihood +finish :: (Event event) => Counts event -> Observed event +finish obs = Observed (counts obs) (calcTotal obs) (countNonTrivial obs) diff --git a/NLP/Probability/SmoothTrie.hs b/NLP/Probability/SmoothTrie.hs new file mode 100644 --- /dev/null +++ b/NLP/Probability/SmoothTrie.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module NLP.Probability.SmoothTrie where +import Data.Monoid +import qualified Data.ListTrie.Map as T +import qualified Data.ListTrie.Base.Map as LT +import Control.Monad (foldM, liftM) +import Data.Maybe (catMaybes, fromMaybe) +import Data.List (intercalate, inits) +import Test.QuickCheck +import Data.Binary +import Text.PrettyPrint.HughesPJClass +import qualified Data.ListTrie.Base.Map as M + + +newtype SmoothTrie map letter holder= SmoothTrie (T.TrieMap map letter holder) + deriving (Show, Binary, Functor) + +instance (M.Map map letter, Arbitrary letter, Arbitrary holder) => Arbitrary (SmoothTrie map letter holder) where + arbitrary = do + holder <- arbitrary + return $ SmoothTrie $ T.fromList holder + +instance (M.Map map letter, Pretty holder, Pretty letter) => Pretty (SmoothTrie map letter holder) where + pPrint (SmoothTrie t) = printRows 1 + where + tlist = T.toList t + printRows n = if null oflen then empty + else + (hang (text "Row " <> int n) 4 + $ vcat $ map (\(k,v) -> (pPrint k) <+> (pPrint v)) oflen) $$ printRows (n + 1) + where oflen = filter ((== n).length.fst) tlist + +instance (Monoid holder, M.Map map letter) => Monoid (SmoothTrie map letter holder) where + mempty = SmoothTrie mempty + mappend (SmoothTrie m) (SmoothTrie m') = SmoothTrie (T.unionWith mappend m m') + mconcat sumtries = SmoothTrie $ T.unionsWith mappend $ [s | SmoothTrie s <-sumtries] + +lookup ks (SmoothTrie t) = T.lookup ks t + +{-# INLINE lookupWithDefault #-} +lookupWithDefault def ks (SmoothTrie t) = fromMaybe def $ T.lookup ks t + +insert key val (SmoothTrie t) = SmoothTrie (T.insert key val t) + +count (SmoothTrie t) = T.size t + +holder st = T.lookup [] st + +addColumn :: (M.Map map letter, Monoid holder) => + [letter] -> holder -> SmoothTrie map letter holder -> SmoothTrie map letter holder +addColumn letters holder trie = trie `mappend` (SmoothTrie trieColumn) + where trieColumn = mconcat $ zipWith T.singleton (inits letters) $ repeat holder diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/estimators.cabal b/estimators.cabal new file mode 100644 --- /dev/null +++ b/estimators.cabal @@ -0,0 +1,55 @@ +name: estimators +version: 0.1 +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 + systems that need to handle large, discrete observation sets and + perform smoothing. +category: Natural Language Processing +license: BSD3 +license-file: LICENSE +author: Sasha Rush +maintainer: +build-Type: Simple +cabal-version: >= 1.2 + +flag testing + description: Testing mode, only build minimal components + default: False + +library + exposed-modules: NLP.Probability.Distribution + NLP.Probability.Observation + NLP.Probability.ConditionalDistribution + NLP.Probability.Example.Trigram + + other-modules: NLP.Probability.SmoothTrie + if flag(testing) + buildable: False + + build-Depends: base >= 3 && < 4, + containers >= 0.1 && < 0.3, + binary, + list-tries, + pretty, + prettyclass, + text + +executable hstestprobdist + main-is: Tests.hs + hs-source-dirs: . tests/ + + build-Depends: base >= 3 && < 4, + containers >= 0.1 && < 0.3, + QuickCheck >= 2, + text, + pretty, + prettyclass, + HUnit, + test-framework, + test-framework-hunit, + test-framework-quickcheck2 + + if !flag(testing) + buildable: False + diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances #-} +module Main where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Test.QuickCheck +import Test.HUnit + +import NLP.Probability.Observation +import NLP.Probability.Distribution +import qualified Data.IntMap as IM + +import qualified Data.Set as S +import Data.List +import Control.Monad (liftM) +import Data.Monoid +main = defaultMain tests + +type SampleEvent = Char + + +tests = + [ []] +