module Bayes.VariableElimination(
priorMarginal
, posteriorMarginal
, interactionGraph
, degreeOrder
, minDegreeOrder
, minFillOrder
, allVariables
, marginal
, mpemarginal
, mpe
, EliminationOrder
) where
import Bayes
import Bayes.Factor
import Data.List(minimumBy,(\\),foldl')
import Data.Maybe(fromJust)
import Data.Function(on)
import qualified Data.Map as M
import Bayes.Factor.PrivateCPT(convertToMaxFactor,CPT,MAXCPT)
import Bayes.Factor.CPT
import Bayes.Factor.MaxCPT
import Bayes.PrivateTypes(DVISet)
import Bayes.VariableElimination.Buckets
allVariables :: (Graph g, Factor f)
=> BayesianNetwork g f
-> [DV]
allVariables g =
let s = allVertexValues g
createDV = factorMainVariable
in
map createDV s
convertToMaxCPT :: Buckets CPT -> Buckets MAXCPT
convertToMaxCPT (Buckets e m) = Buckets e (M.map (map convertToMaxFactor) m)
marginal :: (IsBucketItem f, Factor f)
=> [f]
-> EliminationOrder DV
-> EliminationOrder DV
-> [DVI]
-> f
marginal lf p r assignment =
let bucket = createBuckets lf p r
assignmentFactors = map factorFromInstantiation assignment
bucket' = foldl' addBucket bucket assignmentFactors
Buckets _ resultBucket = foldl' marginalizeOneVariable bucket' p
resultFactor = factorProduct . concat . M.elems $ resultBucket
in
resultFactor
mpemarginal :: [CPT]
-> EliminationOrder DV
-> EliminationOrder DV
-> [DVI]
-> MAXCPT
mpemarginal lf p r assignment =
let bucket = createBuckets lf p r
assignmentFactors = map factorFromInstantiation assignment
bucket' = foldl' addBucket bucket assignmentFactors
bucket'' = foldl' marginalizeOneVariable bucket' p
bucketMax = convertToMaxCPT bucket''
Buckets _ resultBucket = foldl' marginalizeOneVariable bucketMax r
resultFactor = factorProduct . concat . M.elems $ resultBucket
in
resultFactor
mpe :: (Graph g, BayesianDiscreteVariable dva, BayesianDiscreteVariable dvb)
=> BayesianNetwork g CPT
-> EliminationOrder dva
-> EliminationOrder dvb
-> [DVI]
-> [DVISet]
mpe g someP someR assignment =
let p = map dv someP
r = map dv someR
s = allVertexValues g
resultFactor = mpemarginal s p r assignment
in
mpeInstantiations (resultFactor)
posteriorMarginal :: (Graph g, IsBucketItem f, Factor f,Show f, BayesianDiscreteVariable dva, BayesianDiscreteVariable dvb)
=> BayesianNetwork g f
-> EliminationOrder dva
-> EliminationOrder dvb
-> [DVI]
-> f
posteriorMarginal g someP someR assignment =
let p = map dv someP
r = map dv someR
s = allVertexValues g
resultFactor = marginal s p r assignment
norm = factorNorm resultFactor
in
resultFactor `factorDivide` norm
priorMarginal :: (Graph g, IsBucketItem f, Factor f,Show f, BayesianDiscreteVariable dva, BayesianDiscreteVariable dvb)
=> BayesianNetwork g f
-> EliminationOrder dva
-> EliminationOrder dvb
-> f
priorMarginal g someEA someEB =
let ea = map dv someEA
eb = map dv someEB
s = allVertexValues g
resultFactor = marginal s ea eb []
norm = factorNorm resultFactor
in
resultFactor `factorDivide` norm
interactionGraph :: (FoldableWithVertex g,Factor f, UndirectedGraph g')
=> BayesianNetwork g f
-> g' () DV
interactionGraph g =
foldrWithVertex addFactor emptyGraph g
where
addFactor vertex factor graph =
let allvars = factorVariables factor
edges = [(x,y) | x <- allvars, y <- allvars , x /= y]
addNewEdge g (va,vb) =
let g' = addVertex (variableVertex vb) vb . addVertex (variableVertex va) va $ g
in
addEdge (edge (variableVertex va) (variableVertex vb)) () $ g'
in
foldl' addNewEdge graph edges
nbNeighbors :: UndirectedSG () DV
-> DV
-> Int
nbNeighbors g dv =
let r = fromJust $ neighbors g (variableVertex dv)
in
length r
nbMissingLinks :: UndirectedSG () DV
-> DV
-> Int
nbMissingLinks g dv =
let r = fromJust $ neighbors g (variableVertex dv)
edges = [(x,y) | x <- r, y <- r , x /= y, not (isLinkedWithAnEdge g x y)]
in
length edges
degreeOrder :: (FoldableWithVertex g, Factor f, Graph g)
=> BayesianNetwork g f
-> EliminationOrder DV
-> Int
degreeOrder g p =
let ig = interactionGraph g :: UndirectedSG () DV
(_,w) = foldl' processVariable (ig,0) p
in
w
where
addAnEdge g (va,vb) = addEdge (edge va vb) () g
processVariable (g,w) bdv =
let r = fromJust $ neighbors g (variableVertex bdv)
nbNeighbors = length r
edges = [(x,y) | x <- r, y <- r , x /= y, not (isLinkedWithAnEdge g x y)]
g' = removeVertex (variableVertex bdv) (foldl' addAnEdge g edges)
in
if nbNeighbors > w
then
(g',nbNeighbors)
else
(g',w)
eliminationOrderForMetric :: (Graph g, Factor f, FoldableWithVertex g, UndirectedGraph g')
=> (g' () DV -> DV -> Int)
-> BayesianNetwork g f
-> EliminationOrder DV
eliminationOrderForMetric metric g =
let ig = interactionGraph g
s = allVertexValues ig
getOptimalNode _ [] = []
getOptimalNode g l =
let (optimalNode,_) = minimumBy (compare `on` snd) . map (\v -> (v,metric g v)) $ l
g' = removeVertex (variableVertex optimalNode) g
in
optimalNode : getOptimalNode g' (l \\ [optimalNode])
in
getOptimalNode ig s
minDegreeOrder :: (Graph g, Factor f, FoldableWithVertex g)
=> BayesianNetwork g f
-> EliminationOrder DV
minDegreeOrder = eliminationOrderForMetric nbNeighbors
minFillOrder :: (Graph g, Factor f, FoldableWithVertex g)
=> BayesianNetwork g f
-> EliminationOrder DV
minFillOrder = eliminationOrderForMetric nbMissingLinks