diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Grzegorz Chrupala + +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 Grzegorz Chrupala nor the names of other + 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/LDA.hs b/NLP/LDA.hs new file mode 100644 --- /dev/null +++ b/NLP/LDA.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE DeriveGeneric , BangPatterns #-} +-- | Latent Dirichlet Allocation +-- +-- Simple implementation of a collapsed Gibbs sampler for LDA. This +-- library uses the topic modeling terminology (documents, words, +-- topics), even though it is generic. For example if used for word +-- class induction, replace documents with word types, words with +-- features and topics with word classes. + +module NLP.LDA + ( -- * Running samplers + runSampler + , pass + , runLDA + -- * Datatypes + , Sampler + , LDA + , Finalized + , Doc + , D + , W + , Z + -- * Access model information + , docTopics + , wordTopics + , topics + , alphasum + , beta + , topicNum + , vSize + , model + , topicDocs + , topicWords + -- * Initialization and finalization + , initial + , finalize + -- * Prediction + , docTopicWeights + -- * Miscelaneous + , compress + , Table2D + , Table1D + ) +where +-- Standard libraries +import qualified Data.IntMap as IntMap +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import qualified Data.List as List +import Prelude hiding (sum) + +-- Third party module +import GHC.Generics (Generic) +import Data.Random (rvarT) +import Data.RVar +import Data.Random.Distribution.Categorical +import Control.Monad.State +import Data.Random.Source.PureMT (pureMT) +import Data.Word (Word64) + +-- Package modules +import NLP.LDA.Utils (count) +import NLP.LDA.UnboxedMaybeVector () + +-- Exported types +type D = Int +type Z = Int +type W = Int +type Doc = (D, U.Vector (W, Maybe Z)) + +type Table2D = IntMap.IntMap Table1D +type Table1D = IntMap.IntMap Double + +-- | Abstract type holding the settings and the state of the sampler +data LDA = + LDA + { docTopics :: Table2D -- ^ Document-topic counts + , wordTopics :: Table2D -- ^ Word-topic counts + , topics :: Table1D -- ^ Topic counts + , alphasum :: !Double -- ^ alpha * K Dirichlet parameter (topic sparseness) + , beta :: !Double -- ^ beta Dirichlet parameter (word sparseness) + , topicNum :: !Int -- ^ Number of topics K + , vSize :: !Int -- ^ Number of unique words + } deriving (Generic) + +-- | Abstract type holding the LDA model, and the inverse count tables +data Finalized = + Finalized + { model :: LDA -- ^ LDA model + , topicDocs :: Table2D -- ^ Inverse document-topic counts + , topicWords :: Table2D -- ^ Inverse word-topic counts + } + deriving (Generic) + +-- | Custom random variable representing the LDA Gibbs sampler +type Sampler a = RVarT (State LDA) a + +-- Exported functions + +-- | @initial k a b@ initializes model with @k@ topics, @a/k@ alpha +-- hyperparameter and @b@ beta hyperparameter. +initial :: Int -> Double -> Double -> LDA +initial k a b = + LDA { docTopics = IntMap.empty + , wordTopics = IntMap.empty + , topics = IntMap.empty + , alphasum = a + , beta = b + , topicNum = k + , vSize = 0 + } + +-- | @finalize m@ creates a finalized model from LDA model @m@ +finalize :: LDA -> Finalized +finalize m = + Finalized { model = m + , topicDocs = invert . docTopics $ m + , topicWords = invert . wordTopics $ m } + + + +-- | @pass batch@ runs one pass of Gibbs sampling on documents in @batch@ +pass :: V.Vector Doc -> Sampler (V.Vector Doc) +pass = V.mapM passOne + + +-- | @runSampler seed m s@ runs sampler @s@ with @seed@ and initial +-- model @m@. The random number generator used is +-- System.Random.Mersenne.Pure64. +runSampler :: Word64 -> LDA -> Sampler a -> (a, LDA) +runSampler seed m = + flip runState m + . flip evalStateT (pureMT seed) + . sampleRVarTWith lift + + +-- | @runLDA seed n m ds@ creates and runs an LDA sampler with @seed@ +-- for @n@ passes with initial model @m@ on the batch of documents +-- @ds@. The random number generator used is +-- System.Random.Mersenne.Pure64. +runLDA :: Word64 + -> Int + -> LDA + -> V.Vector Doc + -> (V.Vector Doc, LDA) +runLDA seed n m ds = runSampler seed m . foldM (const . pass) ds + $ [1..n] + +-- | Remove zero counts from the doc/topic table +compress :: IntMap.IntMap (IntMap.IntMap Double) + -> IntMap.IntMap (IntMap.IntMap Double) +compress = IntMap.map dezero + +-- Private functions -- + +-- | Run a pass on a single doc +passOne :: Doc -> Sampler Doc +passOne (d, wz) = do + zs <- U.mapM one wz + return (d, U.zip (U.map fst wz) (U.map Just zs)) + where one (w, mz) = do + m <- lift get + let m' = maybe m (update (-1) m d w) mz -- decrement counts + lift $ put m' + z <- randomZ d w -- sample topic + lift $ put (update 1 m' d w z) -- increment counts + return z + +-- | Sample a random topic for doc d and word w +randomZ :: D -> W -> Sampler Z +randomZ d w = do + m <- lift get + sampleCategorical . fromWeightedList . U.toList . U.map swap . U.indexed + . wordTopicWeights m d + $ w + +-- | @topicWeights m d w@ returns the unnormalized probabilities of +-- topics for word @w@ in document @d@ given LDA model @m@. +wordTopicWeights :: LDA -> D -> W -> U.Vector Double +wordTopicWeights m d w = + let k = topicNum m + a = alphasum m / fromIntegral k + b = beta m + dt = IntMap.findWithDefault IntMap.empty d . docTopics $ m + wt = IntMap.findWithDefault IntMap.empty w . wordTopics $ m + v = fromIntegral . vSize $ m + weights = [ (count z dt + a) -- n(z,d) + alpha + * (count z wt + b) -- n(z,w) + beta + * (1/(count z (topics m) + v * b)) + -- n(.,w) + V * beta + | z <- [0..k-1] ] + in U.fromList weights +{-# INLINE wordTopicWeights #-} + +-- | @docTopicWeights m doc@ returns unnormalized topic probabilities +-- for document doc given LDA model @m@ +docTopicWeights :: LDA -> Doc -> U.Vector Double +docTopicWeights m (d, ws) = + U.accumulate (+) (U.replicate (topicNum m) 0) + . U.concatMap (U.indexed . wordTopicWeights m d) + . U.map fst + $ ws +{-# INLINE docTopicWeights #-} + +-- | Update counts in the model corresponding to given doc, word and topic +update :: Double -> LDA -> D -> W -> Z -> LDA +update c m d w z = + m { docTopics = upd c (docTopics m) d z + , wordTopics = upd c (wordTopics m) w z + , topics = IntMap.insertWith' (+) z c (topics m) + , vSize = vSize m + (fromEnum . IntMap.notMember w . wordTopics $ m) + } + +-- FIXME: define a more efficient version +-- | Increment table m by c at key (k,k') +upd :: Double -> Table2D -> Int -> Int -> Table2D +upd c m k k' = IntMap.insertWith' (flip (IntMap.unionWith (+))) + k + (IntMap.singleton k' c) + m +{-# INLINE upd #-} + +sampleCategorical :: Categorical Double Z -> Sampler Z +sampleCategorical = sampleRVarT . rvarT +{-# INLINE sampleCategorical #-} + +dezero :: IntMap.IntMap Double -> IntMap.IntMap Double +dezero = IntMap.filter (/=0) +{-# INLINE dezero #-} + +-- | Swap the order of keys on Table2D +invert :: Table2D -> Table2D +invert outer = + List.foldl' (\z (k,k',v) -> upd v z k k') IntMap.empty + [ (k',k,v) + | (k, inner) <- IntMap.toList outer + , (k', v) <- IntMap.toList inner ] +{-# INLINE invert #-} + +swap :: (Int, Double) -> (Double, Int) +swap (!a, !b) = (b, a) diff --git a/NLP/LDA/UnboxedMaybeVector.hs b/NLP/LDA/UnboxedMaybeVector.hs new file mode 100644 --- /dev/null +++ b/NLP/LDA/UnboxedMaybeVector.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleContexts, + TypeFamilies, ScopedTypeVariables, BangPatterns, + TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module NLP.LDA.UnboxedMaybeVector () +where +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M +import Data.Vector.Unboxed.Base (MVector, Vector, Unbox) + +import Control.Monad ( liftM ) + +newtype instance MVector s (Maybe a) = MV_Maybe (MVector s (a,Bool)) +newtype instance Vector (Maybe a) = V_Maybe (Vector (a,Bool)) + +instance (Num a, Unbox a) => Unbox (Maybe a) + +nothing :: (Num a, Unbox a) => a +nothing = 0 +{-# INLINE nothing #-} + +instance (Num a, Unbox a) => M.MVector MVector (Maybe a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength (MV_Maybe v) = M.basicLength v + basicUnsafeSlice i n (MV_Maybe v) = MV_Maybe $ M.basicUnsafeSlice i n v + basicOverlaps (MV_Maybe v1) (MV_Maybe v2) = M.basicOverlaps v1 v2 + basicUnsafeNew n = MV_Maybe `liftM` M.basicUnsafeNew n + basicUnsafeRead (MV_Maybe v) i = fromPair `liftM` M.basicUnsafeRead v i + basicUnsafeWrite (MV_Maybe v) i mx = M.basicUnsafeWrite v i (maybe (nothing,False) (,True) mx) + +instance (Num a, Unbox a) => G.Vector Vector (Maybe a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicLength (V_Maybe v) = G.basicLength v + basicUnsafeFreeze (MV_Maybe v) = V_Maybe `liftM` G.basicUnsafeFreeze v + basicUnsafeThaw (V_Maybe v) = MV_Maybe `liftM` G.basicUnsafeThaw v + basicUnsafeSlice i n (V_Maybe v) = V_Maybe $ G.basicUnsafeSlice i n v + basicUnsafeIndexM (V_Maybe v) i + = fromPair `liftM` G.basicUnsafeIndexM v i + +fromPair :: (Unbox a) => (a, Bool) -> Maybe a +fromPair (_, False) = Nothing +fromPair (x, True) = Just x +{-# INLINE fromPair #-} diff --git a/NLP/LDA/Utils.hs b/NLP/LDA/Utils.hs new file mode 100644 --- /dev/null +++ b/NLP/LDA/Utils.hs @@ -0,0 +1,12 @@ +module NLP.LDA.Utils + ( count + ) +where +import qualified Data.IntMap as IntMap + +count :: Int -> IntMap.IntMap Double -> Double +count z t = case IntMap.findWithDefault 0 z t of + n | n < 0 -> error "NLP.LDA.Utils.count: negative count" + n -> n +{-# INLINE count #-} + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lda.cabal b/lda.cabal new file mode 100644 --- /dev/null +++ b/lda.cabal @@ -0,0 +1,73 @@ +-- lda.cabal auto-generated by cabal init. For additional options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: lda + +-- 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.0.1 + +-- A short (one-line) description of the package. +Synopsis: Online Latent Dirichlet Allocation + +-- A longer description of the package. +Description: Online Gibbs sampler for Latent Dirichlet Allocation. + LDA is a generative admixture model frequently used + for topic modeling and other applications. The primary + goal of this implementation is to be used for probabilistic + soft word class induction. + The sampler can be used in an online as well as batch mode. + +-- URL for the project homepage or repository. +Homepage: https://bitbucket.org/gchrupala/colada + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Grzegorz Chrupała + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: pitekus@gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Natural Language Processing + + +-- Extra files to be distributed with the package, such as examples or +-- a README. +Extra-source-files: README + +Build-type: Simple + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.2 + + +Library + -- Modules exported by the library. + Exposed-modules: NLP.LDA + , NLP.LDA.UnboxedMaybeVector + + -- Packages needed in order to build this package. + Build-depends: base >= 3 && < 5 + , containers >= 0.4 + , random-fu >= 0.2.1.1 + , rvar >= 0.2 + , random-source >= 0.3.0.2 + , mtl >= 2.0 + , ghc-prim >= 0.2 + , vector >= 0.9 + -- Modules not exported by this package. + Other-modules: NLP.LDA.Utils + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + GHC-options: -O2