diff --git a/DumpCI.hs b/DumpCI.hs new file mode 100644 --- /dev/null +++ b/DumpCI.hs @@ -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 diff --git a/DumpLDA.hs b/DumpLDA.hs new file mode 100644 --- /dev/null +++ b/DumpLDA.hs @@ -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 + diff --git a/DumpST.hs b/DumpST.hs new file mode 100644 --- /dev/null +++ b/DumpST.hs @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/RunCI.hs b/RunCI.hs new file mode 100644 --- /dev/null +++ b/RunCI.hs @@ -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 () + diff --git a/RunLDA.hs b/RunLDA.hs new file mode 100644 --- /dev/null +++ b/RunLDA.hs @@ -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 () + diff --git a/RunST.hs b/RunST.hs new file mode 100644 --- /dev/null +++ b/RunST.hs @@ -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 () + 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/network-topic-models.cabal b/network-topic-models.cabal new file mode 100644 --- /dev/null +++ b/network-topic-models.cabal @@ -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 +