network-topic-models (empty) → 0.2.0.1
raw patch · 9 files changed
+923/−0 lines, 9 filesdep +basedep +bayes-stackdep +bimapsetup-changed
Dependencies added: base, bayes-stack, bimap, bytestring, cereal, containers, deepseq, directory, filepath, logfloat, mwc-random, optparse-applicative, random-fu, statistics, stm, text, transformers, vector
Files
- DumpCI.hs +114/−0
- DumpLDA.hs +93/−0
- DumpST.hs +113/−0
- LICENSE +30/−0
- RunCI.hs +186/−0
- RunLDA.hs +151/−0
- RunST.hs +183/−0
- Setup.hs +2/−0
- network-topic-models.cabal +51/−0
+ DumpCI.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Monoid+import Data.Foldable+import Data.List+import Data.Function (on)+import Options.Applicative++import qualified Data.Map as M+import qualified Data.ByteString as BS++import qualified Data.Text.Lazy.IO as TL+import qualified Data.Text.Lazy.Builder as TB+import Data.Text.Lazy.Builder.Int+import Data.Text.Lazy.Builder.RealFloat+import Data.Serialize++import System.FilePath ((</>)) +import Text.Printf++import BayesStack.Models.Topic.CitationInfluence+import SerializeText+import ReadData+import FormatMultinom + +data Opts = Opts { nElems :: Maybe Int+ , dumper :: Dumper+ , sweepDir :: FilePath+ , sweepNum :: Maybe Int+ }+ +type Dumper = Opts -> NetData -> MState+ -> (Item -> TB.Builder) -> (Node -> TB.Builder)+ -> TB.Builder++showB :: Show a => a -> TB.Builder+showB = TB.fromString . show++readDumper :: String -> Maybe Dumper+readDumper "phis" = Just $ \opts nd m showItem showNode ->+ formatMultinoms (\(Topic n)->"Topic "<>decimal n) showItem (nElems opts) (stPhis m)++readDumper "psis" = Just $ \opts nd m showItem showNode ->+ formatMultinoms (\(Citing n)->showNode n) showB (nElems opts) (stPsis m)++readDumper "lambdas"= Just $ \opts nd m showItem showNode ->+ formatMultinoms showB showB (nElems opts) (stLambdas m)++readDumper "omegas" = Just $ \opts nd m showItem showNode ->+ formatMultinoms showB showB (nElems opts) (stOmegas m)++readDumper "gammas" = Just $ \opts nd m showItem showNode ->+ formatMultinoms showB showB (nElems opts) (stGammas m)+ +readDumper "influences" = Just $ \opts nd m showItem showNode ->+ let formatProb = formatRealFloat Exponent (Just 3) . realToFrac+ formatInfluences u =+ foldMap (\(n,p)->"\t" <> showB n <> "\t" <> formatProb p <> "\n")+ $ sortBy (flip (compare `on` snd))+ $ M.assocs $ influence nd m u+ in foldMap (\u->"\n" <> showB u <> "\n" <> formatInfluences u)+ $ M.keys $ stGammas m++readDumper _ = Nothing++opts = Opts+ <$> nullOption ( long "top"+ <> short 'n'+ <> value Nothing+ <> reader (Just . auto)+ <> metavar "N"+ <> help "Number of elements to output from each distribution"+ )+ <*> argument readDumper+ ( metavar "STR"+ <> help "One of: phis, psis, lambdas, omegas, gammas, influences"+ )+ <*> strOption ( long "sweeps"+ <> short 's'+ <> value "sweeps"+ <> metavar "DIR"+ <> help "The directory of sweeps to dump"+ )+ <*> option ( long "sweep-n"+ <> short 'N'+ <> reader (Just . auto)+ <> value Nothing+ <> metavar "N"+ <> help "The sweep number to dump"+ )++readSweep :: FilePath -> IO MState+readSweep fname = (either error id . runGet get) <$> BS.readFile fname++readNetData :: FilePath -> IO NetData+readNetData fname = (either error id . runGet get) <$> BS.readFile fname++main = do+ args <- execParser $ info (helper <*> opts) + ( fullDesc + <> progDesc "Dump distributions from an citation influence model sweep"+ <> header "dump-ci - Dump distributions from an citation influence model sweep"+ )++ nd <- readNetData $ sweepDir args </> "data"+ itemMap <- readItemMap $ sweepDir args+ nodeMap <- readNodeMap $ sweepDir args+ m <- case sweepNum args of+ Nothing -> readSweep =<< getLastSweep (sweepDir args)+ Just n -> readSweep $ sweepDir args </> printf "%05d.state" n++ let showItem = showB . (itemMap M.!)+ showNode = showB . (nodeMap M.!)+ TL.putStr $ TB.toLazyText $ dumper args args nd m showItem showNode
+ DumpLDA.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Monoid+import Options.Applicative++import qualified Data.Map as M+import qualified Data.ByteString as BS++import qualified Data.Text.Lazy.IO as TL+import Data.Text.Lazy.Builder.Int+import qualified Data.Text.Lazy.Builder as TB+import Data.Serialize++import System.FilePath ((</>)) +import Text.Printf ++import BayesStack.Models.Topic.LDA+import SerializeText+import ReadData+import FormatMultinom ++data Opts = Opts { nElems :: Maybe Int+ , dumper :: Dumper+ , sweepDir :: FilePath+ , sweepNum :: Maybe Int+ }++type Dumper = Opts -> NetData -> MState+ -> (Item -> TB.Builder) -> (Node -> TB.Builder)+ -> TB.Builder+ +showB :: Show a => a -> TB.Builder+showB = TB.fromString . show++readDumper :: String -> Maybe Dumper+readDumper "thetas" = Just $ \opts nd m showItem showNode ->+ formatMultinoms showNode showB (nElems opts) (stThetas m)++readDumper "phis" = Just $ \opts nd m showItem showNode ->+ formatMultinoms (\(Topic n)->"Topic "<>decimal n) showItem (nElems opts) (stPhis m)++readDumper _ = Nothing++opts = Opts+ <$> nullOption ( long "top"+ <> short 'n'+ <> value Nothing+ <> reader (Just . auto)+ <> metavar "N"+ <> help "Number of elements to output from each distribution"+ )+ <*> argument readDumper+ ( metavar "STR"+ <> help "One of: thetas, lambdas"+ )+ <*> strOption ( long "sweeps"+ <> short 's'+ <> value "sweeps"+ <> metavar "DIR"+ <> help "The directory of sweeps to dump"+ )+ <*> option ( long "number"+ <> short 'N'+ <> reader (Just . auto)+ <> value Nothing+ <> metavar "N"+ <> help "The sweep number to dump"+ )++readSweep :: FilePath -> IO MState+readSweep fname = (either error id . runGet get) <$> BS.readFile fname++readNetData :: FilePath -> IO NetData+readNetData fname = (either error id . runGet get) <$> BS.readFile fname++main = do+ args <- execParser $ info (helper <*> opts) + ( fullDesc + <> progDesc "Dump distributions from an LDA sweep"+ <> header "dump-lda - Dump distributions from an LDA sweep"+ )++ nd <- readNetData $ sweepDir args </> "data"+ itemMap <- readItemMap $ sweepDir args+ nodeMap <- readNodeMap $ sweepDir args+ m <- case sweepNum args of+ Nothing -> readSweep =<< getLastSweep (sweepDir args)+ Just n -> readSweep $ sweepDir args </> printf "%05d.state" n+ + let showItem = showB . (itemMap M.!)+ showNode = showB . (nodeMap M.!)+ TL.putStr $ TB.toLazyText $ dumper args args nd m showItem showNode+
+ DumpST.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Monoid+import Data.Foldable+import Data.List+import Data.Function (on)+import Options.Applicative++import qualified Data.Map as M+import qualified Data.ByteString as BS++import qualified Data.Text.Lazy.IO as TL+import qualified Data.Text.Lazy.Builder as TB+import Data.Text.Lazy.Builder.Int+import Data.Text.Lazy.Builder.RealFloat+import Data.Serialize++import System.FilePath ((</>)) +import Text.Printf ++import BayesStack.Models.Topic.SharedTaste+import SerializeText+import ReadData+import FormatMultinom+ +data Opts = Opts { nElems :: Maybe Int+ , dumper :: Dumper+ , sweepDir :: FilePath+ , sweepNum :: Maybe Int+ }+ +type Dumper = Opts -> NetData -> MState+ -> (Item -> TB.Builder) -> (Node -> TB.Builder)+ -> TB.Builder++showB :: Show a => a -> TB.Builder+showB = TB.fromString . show++readDumper :: String -> Maybe Dumper+readDumper "phis" = Just $ \opts nd m showItem showNode ->+ formatMultinoms (\(Topic n)->"Topic "<>decimal n) showItem (nElems opts) (stPhis m)++readDumper "psis" = Just $ \opts nd m showItem showNode ->+ formatMultinoms showNode showB (nElems opts) (stPsis m)++readDumper "lambdas"= Just $ \opts nd m showItem showNode ->+ formatMultinoms showB showB (nElems opts) (stLambdas m)++readDumper "omegas" = Just $ \opts nd m showItem showNode ->+ formatMultinoms showB showB (nElems opts) (stOmegas m)++readDumper "gammas" = Just $ \opts nd m showItem showNode ->+ formatMultinoms showB showB (nElems opts) (stGammas m)+ +readDumper "influences" = Just $ \opts nd m showItem showNode ->+ let formatProb = formatRealFloat Exponent (Just 3) . realToFrac+ formatInfluences u =+ foldMap (\(n,p)->"\t" <> showNode n <> "\t" <> formatProb p <> "\n")+ $ sortBy (flip (compare `on` snd))+ $ M.assocs $ influence nd m u+ in foldMap (\u->"\n" <> showB u <> "\n" <> formatInfluences u)+ $ M.keys $ stGammas m++opts = Opts+ <$> nullOption ( long "top"+ <> short 'n'+ <> value Nothing+ <> reader (Just . auto)+ <> metavar "N"+ <> help "Number of elements to output from each distribution"+ )+ <*> argument readDumper+ ( metavar "STR"+ <> help "One of: phis, psis, lambdas, omegas, gammas, influences"+ )+ <*> strOption ( long "sweeps"+ <> short 's'+ <> value "sweeps"+ <> metavar "DIR"+ <> help "The directory of sweeps to dump"+ )+ <*> option ( long "number"+ <> short 'N'+ <> reader (Just . auto)+ <> value Nothing+ <> metavar "N"+ <> help "The sweep number to dump"+ )++readSweep :: FilePath -> IO MState+readSweep fname = (either error id . runGet get) <$> BS.readFile fname++readNetData :: FilePath -> IO NetData+readNetData fname = (either error id . runGet get) <$> BS.readFile fname++main = do+ args <- execParser $ info (helper <*> opts) + ( fullDesc + <> progDesc "Dump distributions from an shared taste model sweep"+ <> header "dump-lda - Dump distributions from an shared taste model sweep"+ )++ nd <- readNetData $ sweepDir args </> "data"+ itemMap <- readItemMap $ sweepDir args+ nodeMap <- readNodeMap $ sweepDir args+ m <- case sweepNum args of+ Nothing -> readSweep =<< getLastSweep (sweepDir args)+ Just n -> readSweep $ sweepDir args </> printf "%05d.state" n++ let showItem = showB . (itemMap M.!)+ showNode = showB . (nodeMap M.!)+ TL.putStr $ TB.toLazyText $ dumper args args nd m showItem showNode+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Ben Gamari++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 Ben Gamari 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.
+ RunCI.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, StandaloneDeriving #-}++import Prelude hiding (mapM) ++import Options.Applicative +import Data.Monoid ((<>)) +import Control.Monad.Trans.Class ++import Data.Vector (Vector) +import qualified Data.Vector.Generic as V +import Statistics.Sample (mean) ++import Data.Traversable (mapM) +import qualified Data.Set as S+import Data.Set (Set)+import qualified Data.Map as M++import ReadData +import SerializeText+import qualified RunSampler as Sampler+import BayesStack.DirMulti+import BayesStack.Models.Topic.CitationInfluence+import BayesStack.UniqueKey++import qualified Data.Text as T+import qualified Data.Text.IO as TIO+ +import System.Directory (createDirectoryIfMissing)+import System.FilePath.Posix ((</>))+import Data.Serialize+import qualified Data.ByteString as BS+import Text.Printf++import Data.Random+import System.Random.MWC + +data RunOpts = RunOpts { arcsFile :: FilePath+ , nodesFile :: FilePath+ , stopwords :: Maybe FilePath+ , nTopics :: Int+ , samplerOpts :: Sampler.SamplerOpts+ , hyperParams :: HyperParams+ }+ +data HyperParams = HyperParams+ { alphaPsi :: Double+ , alphaLambda :: Double+ , alphaPhi :: Double+ , alphaOmega :: Double+ , alphaGammaShared :: Double+ , alphaGammaOwn :: Double+ }+ deriving (Show, Eq)+ +runOpts = RunOpts + <$> strOption ( long "arcs"+ <> short 'a'+ <> metavar "FILE"+ <> help "File containing arcs"+ )+ <*> strOption ( long "nodes"+ <> short 'n'+ <> metavar "FILE"+ <> help "File containing nodes' items"+ )+ <*> nullOption ( long "stopwords"+ <> short 's'+ <> metavar "FILE"+ <> reader (Just . Just)+ <> value Nothing+ <> help "Stop words list"+ )+ <*> option ( long "topics"+ <> short 't'+ <> metavar "N"+ <> value 20+ <> help "Number of topics"+ )+ <*> Sampler.samplerOpts+ <*> hyperOpts+ +hyperOpts = HyperParams+ <$> option ( long "prior-psi"+ <> value 1+ <> help "Dirichlet parameter for prior on psi"+ )+ <*> option ( long "prior-lambda"+ <> value 0.1+ <> help "Dirichlet parameter for prior on lambda"+ )+ <*> option ( long "prior-phi"+ <> value 0.01+ <> help "Dirichlet parameter for prior on phi"+ )+ <*> option ( long "prior-omega"+ <> value 0.01+ <> help "Dirichlet parameter for prior on omega"+ )+ <*> option ( long "prior-gamma-shared"+ <> value 0.9+ <> help "Beta parameter for prior on gamma (shared)"+ )+ <*> option ( long "prior-gamma-own"+ <> value 0.1+ <> help "Beta parameter for prior on gamma (own)"+ )++mapMKeys :: (Ord k, Ord k', Monad m, Applicative m)+ => (a -> m a') -> (k -> m k') -> M.Map k a -> m (M.Map k' a')+mapMKeys f g x = M.fromList <$> (mapM (\(k,v)->(,) <$> g k <*> f v) $ M.assocs x)++termsToItems :: M.Map NodeName [Term] -> Set (NodeName, NodeName)+ -> ( (M.Map Node [Item], Set (Node, Node))+ , (M.Map Item Term, M.Map Node NodeName))+termsToItems nodes arcs =+ let ((d', nodeMap), itemMap) =+ runUniqueKey' [Item i | i <- [0..]] $+ runUniqueKeyT' [Node i | i <- [0..]] $ do+ a <- mapMKeys (mapM (lift . getUniqueKey)) getUniqueKey nodes+ b <- S.fromList <$> mapM (\(x,y)->(,) <$> getUniqueKey x <*> getUniqueKey y)+ (S.toList arcs)+ return (a,b)+ in (d', (itemMap, nodeMap))++netData :: HyperParams -> M.Map Node [Item] -> Set Arc -> Int -> NetData+netData hp nodeItems arcs nTopics = cleanNetData $ + NetData { dAlphaPsi = alphaPsi hp+ , dAlphaLambda = alphaLambda hp+ , dAlphaPhi = alphaPhi hp+ , dAlphaOmega = alphaOmega hp+ , dAlphaGammaShared = alphaGammaShared hp+ , dAlphaGammaOwn = alphaGammaOwn hp+ , dArcs = arcs+ , dItems = S.unions $ map S.fromList $ M.elems nodeItems+ , dTopics = S.fromList [Topic i | i <- [1..nTopics]]+ , dNodeItems = M.fromList+ $ zip [NodeItem i | i <- [0..]]+ $ do (n,items) <- M.assocs nodeItems+ item <- items+ return (n, item)+ }+ +opts = info runOpts+ ( fullDesc+ <> progDesc "Learn citation influence model"+ <> header "run-ci - learn citation influence model"+ )++edgesToArcs :: Set (Node, Node) -> Set Arc+edgesToArcs = S.map (\(a,b)->Arc (Citing a, Cited b))++instance Sampler.SamplerModel MState where+ estimateHypers = id -- reestimate -- FIXME+ modelLikelihood = modelLikelihood+ summarizeHypers ms = "" -- FIXME++main = do+ args <- execParser opts+ stopWords <- case stopwords args of+ Just f -> S.fromList . T.words <$> TIO.readFile f+ Nothing -> return S.empty+ printf "Read %d stopwords\n" (S.size stopWords)++ ((nodeItems, a), (itemMap, nodeMap)) <- termsToItems+ <$> readNodeItems stopWords (nodesFile args)+ <*> readEdges (arcsFile args)+ let arcs = edgesToArcs a++ let sweepsDir = Sampler.sweepsDir $ samplerOpts args+ createDirectoryIfMissing False sweepsDir+ BS.writeFile (sweepsDir </> "item-map") $ runPut $ put itemMap+ BS.writeFile (sweepsDir </> "node-map") $ runPut $ put nodeMap++ let termCounts = V.fromListN (M.size nodeItems)+ $ map length $ M.elems nodeItems :: Vector Int+ printf "Read %d arcs, %d nodes, %d node-items\n" (S.size arcs) (M.size nodeItems) (V.sum termCounts)+ printf "Mean terms per document: %1.2f\n" (mean $ V.map realToFrac termCounts)+ + withSystemRandom $ \mwc->do+ let nd = netData (hyperParams args) nodeItems arcs (nTopics args)+ BS.writeFile (sweepsDir </> "data") $ runPut $ put nd+ mInit <- runRVar (randomInitialize nd) mwc+ let m = model nd mInit+ Sampler.runSampler (samplerOpts args) m (updateUnits nd)+ return ()+
+ RunLDA.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, StandaloneDeriving #-}++import Prelude hiding (mapM) ++import Options.Applicative +import Data.Monoid ((<>)) +import Control.Monad.Trans.Class ++import Data.Vector (Vector) +import qualified Data.Vector.Generic as V +import Statistics.Sample (mean) ++import Data.Traversable (mapM) +import qualified Data.Set as S+import Data.Set (Set)+import qualified Data.Map.Strict as M++import ReadData +import SerializeText+import qualified RunSampler as Sampler+import BayesStack.DirMulti+import BayesStack.Models.Topic.LDA+import BayesStack.UniqueKey++import qualified Data.Text as T+import qualified Data.Text.IO as TIO+ +import System.Directory (createDirectoryIfMissing)+import System.FilePath.Posix ((</>))+import Data.Serialize+import qualified Data.ByteString as BS+import Text.Printf++import Data.Random+import System.Random.MWC + +data RunOpts = RunOpts { nodesFile :: FilePath+ , stopwords :: Maybe FilePath+ , nTopics :: Int+ , samplerOpts :: Sampler.SamplerOpts+ , hyperParams :: HyperParams+ }++data HyperParams = HyperParams+ { alphaTheta :: Double+ , alphaPhi :: Double+ }+ deriving (Show, Eq)+ +runOpts :: Parser RunOpts+runOpts = RunOpts + <$> strOption ( long "nodes"+ <> short 'n'+ <> metavar "FILE"+ <> help "File containing nodes and their associated items"+ )+ <*> nullOption ( long "stopwords"+ <> short 's'+ <> metavar "FILE"+ <> reader (Just . Just)+ <> value Nothing+ <> help "Stop word list"+ )+ <*> option ( long "topics"+ <> short 't'+ <> metavar "N"+ <> value 20+ <> help "Number of topics"+ )+ <*> Sampler.samplerOpts+ <*> hyperOpts+ +hyperOpts = HyperParams+ <$> option ( long "prior-theta"+ <> value 1+ <> help "Dirichlet parameter for prior on theta"+ )+ <*> option ( long "prior-phi"+ <> value 0.1+ <> help "Dirichlet parameter for prior on phi"+ )++mapMKeys :: (Ord k, Ord k', Monad m, Applicative m)+ => (a -> m a') -> (k -> m k') -> M.Map k a -> m (M.Map k' a')+mapMKeys f g x = M.fromList <$> (mapM (\(k,v)->(,) <$> g k <*> f v) $ M.assocs x)++termsToItems :: M.Map NodeName [Term]+ -> (M.Map Node [Item], (M.Map Item Term, M.Map Node NodeName))+termsToItems nodes =+ let ((d', nodeMap), itemMap) =+ runUniqueKey' [Item i | i <- [0..]] $+ runUniqueKeyT' [Node i | i <- [0..]] $ do+ mapMKeys (mapM (lift . getUniqueKey)) getUniqueKey nodes+ in (d', (itemMap, nodeMap))++netData :: HyperParams -> M.Map Node [Item] -> Int -> NetData+netData hp nodeItems nTopics = + NetData { dAlphaTheta = alphaTheta hp+ , dAlphaPhi = alphaPhi hp+ , dItems = S.unions $ map S.fromList $ M.elems nodeItems+ , dTopics = S.fromList [Topic i | i <- [1..nTopics]]+ , dNodeItems = M.fromList+ $ zip [NodeItem i | i <- [0..]]+ $ do (n,items) <- M.assocs nodeItems+ item <- items+ return (n, item)+ , dNodes = M.keysSet nodeItems+ }+ +opts :: ParserInfo RunOpts+opts = info runOpts ( fullDesc+ <> progDesc "Learn LDA model"+ <> header "run-lda - learn LDA model"+ )++instance Sampler.SamplerModel MState where+ estimateHypers = reestimate+ modelLikelihood = modelLikelihood+ summarizeHypers ms = + " phi : "++show (dmAlpha $ snd $ M.findMin $ stPhis ms)++"\n"+++ " theta: "++show (dmAlpha $ snd $ M.findMin $ stThetas ms)++"\n"++main :: IO ()+main = do+ args <- execParser opts+ stopWords <- case stopwords args of+ Just f -> S.fromList . T.words <$> TIO.readFile f+ Nothing -> return S.empty+ printf "Read %d stopwords\n" (S.size stopWords)++ (nodeItems, (itemMap, nodeMap)) <- termsToItems+ <$> readNodeItems stopWords (nodesFile args)++ let sweepsDir = Sampler.sweepsDir $ samplerOpts args+ createDirectoryIfMissing False sweepsDir+ BS.writeFile (sweepsDir </> "item-map") $ runPut $ put itemMap+ BS.writeFile (sweepsDir </> "node-map") $ runPut $ put nodeMap++ let termCounts = V.fromListN (M.size nodeItems)+ $ map length $ M.elems nodeItems :: Vector Int+ printf "Read %d nodes\n" (M.size nodeItems)+ printf "Mean items per node: %1.2f\n" (mean $ V.map realToFrac termCounts)+ + withSystemRandom $ \mwc->do+ let nd = netData (hyperParams args) nodeItems (nTopics args)+ BS.writeFile (sweepsDir </> "data") $ runPut $ put nd+ mInit <- runRVar (randomInitialize nd) mwc+ let m = model nd mInit+ Sampler.runSampler (samplerOpts args) m (updateUnits nd)+ return ()+
+ RunST.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, StandaloneDeriving #-}++import Prelude hiding (mapM) ++import Options.Applicative +import Data.Monoid ((<>)) +import Control.Monad.Trans.Class ++import Data.Vector (Vector) +import qualified Data.Vector.Generic as V +import Statistics.Sample (mean) ++import Data.Traversable (mapM) +import qualified Data.Set as S+import Data.Set (Set)+import qualified Data.Map as M++import ReadData +import SerializeText+import qualified RunSampler as Sampler+import BayesStack.DirMulti+import BayesStack.Models.Topic.SharedTaste+import BayesStack.UniqueKey++import qualified Data.Text as T+import qualified Data.Text.IO as TIO++import System.Directory (createDirectoryIfMissing)+import System.FilePath.Posix ((</>))+import Data.Serialize+import qualified Data.ByteString as BS+import Text.Printf+ +import Data.Random+import System.Random.MWC + +data RunOpts = RunOpts { arcsFile :: FilePath+ , nodesFile :: FilePath+ , stopwords :: Maybe FilePath+ , nTopics :: Int+ , samplerOpts :: Sampler.SamplerOpts+ , hyperParams :: HyperParams+ }+ +data HyperParams = HyperParams+ { alphaPsi :: Double+ , alphaLambda :: Double+ , alphaPhi :: Double+ , alphaOmega :: Double+ , alphaGammaShared :: Double+ , alphaGammaOwn :: Double+ }+ deriving (Show, Eq)++runOpts = RunOpts + <$> strOption ( long "edges"+ <> short 'e'+ <> metavar "FILE"+ <> help "File containing edges"+ )+ <*> strOption ( long "nodes"+ <> short 'n'+ <> metavar "FILE"+ <> help "File containing nodes' items"+ )+ <*> nullOption ( long "stopwords"+ <> short 's'+ <> metavar "FILE"+ <> reader (Just . Just)+ <> value Nothing+ <> help "Stop words list"+ )+ <*> option ( long "topics"+ <> short 't'+ <> metavar "N"+ <> value 20+ <> help "Number of topics"+ )+ <*> Sampler.samplerOpts+ <*> hyperOpts+ +hyperOpts = HyperParams+ <$> option ( long "prior-psi"+ <> value 1+ <> help "Dirichlet parameter for prior on psi"+ )+ <*> option ( long "prior-lambda"+ <> value 0.1+ <> help "Dirichlet parameter for prior on lambda"+ )+ <*> option ( long "prior-phi"+ <> value 0.01+ <> help "Dirichlet parameter for prior on phi"+ )+ <*> option ( long "prior-omega"+ <> value 0.01+ <> help "Dirichlet parameter for prior on omega"+ )+ <*> option ( long "prior-gamma-shared"+ <> value 0.9+ <> help "Beta parameter for prior on gamma (shared)"+ )+ <*> option ( long "prior-gamma-own"+ <> value 0.1+ <> help "Beta parameter for prior on gamma (own)"+ )+ +mapMKeys :: (Ord k, Ord k', Monad m, Applicative m)+ => (a -> m a') -> (k -> m k') -> M.Map k a -> m (M.Map k' a')+mapMKeys f g x = M.fromList <$> (mapM (\(k,v)->(,) <$> g k <*> f v) $ M.assocs x)++termsToItems :: M.Map NodeName [Term] -> Set (NodeName, NodeName)+ -> ( (M.Map Node [Item], Set (Node, Node))+ , (M.Map Item Term, M.Map Node NodeName))+termsToItems nodes arcs =+ let ((d', nodeMap), itemMap) =+ runUniqueKey' [Item i | i <- [0..]] $+ runUniqueKeyT' [Node i | i <- [0..]] $ do+ a <- mapMKeys (mapM (lift . getUniqueKey)) getUniqueKey nodes+ b <- S.fromList <$> mapM (\(x,y)->(,) <$> getUniqueKey x <*> getUniqueKey y)+ (S.toList arcs)+ return (a,b)+ in (d', (itemMap, nodeMap))++netData :: HyperParams -> M.Map Node [Item] -> Set Edge -> Int -> NetData+netData hp nodeItems edges nTopics = + NetData { dAlphaPsi = alphaPsi hp+ , dAlphaLambda = alphaLambda hp+ , dAlphaPhi = alphaPhi hp+ , dAlphaOmega = alphaOmega hp+ , dAlphaGammaShared = alphaGammaShared hp+ , dAlphaGammaOwn = alphaGammaOwn hp+ , dEdges = edges+ , dItems = S.unions $ map S.fromList $ M.elems nodeItems+ , dTopics = S.fromList [Topic i | i <- [1..nTopics]]+ , dNodeItems = M.fromList+ $ zip [NodeItem i | i <- [0..]]+ $ do (n,items) <- M.assocs nodeItems+ item <- items+ return (n, item)+ }+ +opts = info runOpts+ ( fullDesc+ <> progDesc "Learn shared taste model"+ <> header "run-st - learn shared taste model"+ )++instance Sampler.SamplerModel MState where+ estimateHypers = id -- reestimate -- FIXME+ modelLikelihood = modelLikelihood+ summarizeHypers ms = "" -- FIXME++main = do+ args <- execParser opts+ stopWords <- case stopwords args of+ Just f -> S.fromList . T.words <$> TIO.readFile f+ Nothing -> return S.empty+ printf "Read %d stopwords\n" (S.size stopWords)++ ((nodeItems, a), (itemMap, nodeMap)) <- termsToItems+ <$> readNodeItems stopWords (nodesFile args)+ <*> readEdges (arcsFile args)+ let edges = S.map Edge a++ let sweepsDir = Sampler.sweepsDir $ samplerOpts args+ createDirectoryIfMissing False sweepsDir+ BS.writeFile (sweepsDir </> "item-map") $ runPut $ put itemMap+ BS.writeFile (sweepsDir </> "node-map") $ runPut $ put nodeMap++ let termCounts = V.fromListN (M.size nodeItems)+ $ map length $ M.elems nodeItems :: Vector Int+ printf "Read %d edges, %d items\n" (S.size edges) (M.size nodeItems)+ printf "Mean items per node: %1.2f\n" (mean $ V.map realToFrac termCounts)+ + withSystemRandom $ \mwc->do+ let nd = netData (hyperParams args) nodeItems edges 10+ BS.writeFile (sweepsDir </> "data") $ runPut $ put nd+ mInit <- runRVar (randomInitialize nd) mwc+ let m = model nd mInit+ Sampler.runSampler (samplerOpts args) m (updateUnits nd)+ return ()+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ network-topic-models.cabal view
@@ -0,0 +1,51 @@+-- Initial bayes-stack-topic-models.cabal generated by cabal init. For +-- further documentation, see http://haskell.org/cabal/users-guide/++name: network-topic-models+version: 0.2.0.1+synopsis: A few network topic model implementations for bayes-stack+description: Implementations of a few network topic models build upon bayes-stack.+ The package includes Latent Dirichlet Allocation+ (LDA), the shared taste model, and the citation+ influence model.+homepage: https://github.com/bgamari/bayes-stack+license: BSD3+license-file: LICENSE+author: Ben Gamari+maintainer: bgamari.foss@gmail.com+copyright: Copyright (c) 2012 Ben Gamari+category: Math+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: https://github.com/bgamari/bayes-stack.git++executable bayes-stack-lda+ main-is: RunLDA.hs+ ghc-options: -threaded+ build-depends: base ==4.6.*, optparse-applicative ==0.4.*, filepath ==1.3.*, vector >=0.9 && <0.11, statistics ==0.10.*, bimap ==0.2.*, containers ==0.5.*, transformers ==0.3.*, bayes-stack ==0.2.*, text ==0.11.*, random-fu ==0.2.*, mwc-random ==0.12.*, logfloat ==0.12.*, bytestring ==0.10.*, cereal ==0.3.*, stm ==2.4.*, deepseq ==1.3.*, directory++executable bayes-stack-st+ main-is: RunST.hs+ ghc-options: -threaded+ build-depends: base ==4.6.*, optparse-applicative ==0.4.*, filepath ==1.3.*, vector >=0.9 && <0.11, statistics ==0.10.*, bimap ==0.2.*, containers ==0.5.*, transformers ==0.3.*, bayes-stack ==0.2.*, text ==0.11.*, random-fu ==0.2.*, mwc-random ==0.12.*, logfloat ==0.12.*, bytestring ==0.10.*, cereal ==0.3.*, stm ==2.4.*, deepseq ==1.3.*, directory++executable bayes-stack-ci+ main-is: RunCI.hs+ ghc-options: -threaded+ build-depends: base ==4.6.*, optparse-applicative ==0.4.*, filepath ==1.3.*, vector >=0.9 && <0.11, statistics ==0.10.*, bimap ==0.2.*, containers ==0.5.*, transformers ==0.3.*, bayes-stack ==0.2.*, text ==0.11.*, random-fu ==0.2.*, mwc-random ==0.12.*, logfloat ==0.12.*, bytestring ==0.10.*, cereal ==0.3.*, stm ==2.4.*, deepseq ==1.3.*, directory++executable bayes-stack-dump-lda+ main-is: DumpLDA.hs+ build-depends: base ==4.6.*, optparse-applicative ==0.4.*, filepath ==1.3.*, vector >=0.9 && <0.11, statistics ==0.10.*, bimap ==0.2.*, containers ==0.5.*, transformers ==0.3.*, bayes-stack ==0.2.*, text ==0.11.*, random-fu ==0.2.*, mwc-random ==0.12.*, logfloat ==0.12.*, bytestring ==0.10.*, cereal ==0.3.*, deepseq ==1.3.*, directory++executable bayes-stack-dump-st+ main-is: DumpST.hs+ build-depends: base ==4.6.*, optparse-applicative ==0.4.*, filepath ==1.3.*, vector >=0.9 && <0.11, statistics ==0.10.*, bimap ==0.2.*, containers ==0.5.*, transformers ==0.3.*, bayes-stack ==0.2.*, text ==0.11.*, random-fu ==0.2.*, mwc-random ==0.12.*, logfloat ==0.12.*, bytestring ==0.10.*, cereal ==0.3.*, deepseq ==1.3.*, directory++executable bayes-stack-dump-ci+ main-is: DumpCI.hs+ build-depends: base ==4.6.*, optparse-applicative ==0.4.*, filepath ==1.3.*, vector >=0.9 && <0.11, statistics ==0.10.*, bimap ==0.2.*, containers ==0.5.*, transformers ==0.3.*, bayes-stack ==0.2.*, text ==0.11.*, random-fu ==0.2.*, mwc-random ==0.12.*, logfloat ==0.12.*, bytestring ==0.10.*, cereal ==0.3.*, deepseq ==1.3.*, directory+