Probability Trees
Previously, I tried to figure out how to make the probability monad more “listy”. I read a little more about the topic (especially Erwig and Kollmansberger 2006; and Kidd 2007).
I then thought about what a probability monad would look like if it was based on other data structures. I feel like the standard version really wants to be:
newtype ProperProb a = ProperProb
yes :: Map a (Product Rational) } {
But of course a monad instance isn’t allowed.
Similar to a map, though, is a binary tree:
data BinaryTree a = Leaf
| Node (BinaryTree a) a (BinaryTree a)
And it feels better for probability - flatter, somehow. Transmuting it into a probability-thing:
data Odds a = Certain a
| Choice (Odds a) Rational (Odds a)
deriving (Eq, Functor, Foldable, Show)
That looks good to me. A choice between two different branches feels more natural than a choice between a head and a tail.
The fold is similar to before, with an unfold for good measure:
foldOdds :: (b -> Rational -> b -> b) -> (a -> b) -> Odds a -> b
= r where
foldOdds f b Certain x) = b x
r (Choice xs p ys) = f (r xs) p (r ys)
r (
unfoldOdds :: (b -> Either a (b,Rational,b)) -> b -> Odds a
= r where
unfoldOdds f = case f b of
r b Left a -> Certain a
Right (x,p,y) -> Choice (r x) p (r y)
fi :: Bool -> a -> a -> a
True t _ = t
fi False _ f = f fi
I changed the pattern synonym a little:
unRatio :: Num a => Rational -> (a,a)
= numerator &&& denominator
unRatio >>> fromInteger *** fromInteger
pattern n :% d <- (unRatio -> (n,d))
Then, the probOf
function:
probOf :: Eq a => a -> Odds a -> Rational
= foldOdds f b where
probOf e = fi (e == x) 1 0
b x :%d) y = (x * n + y * d) / (n + d) f x (n
This version doesn’t have the option for short-circuiting on the first value it finds.
For generating from lists, you can try to evenly divide the list among each branch.
fromListOdds :: (([b], Int) -> Integer) -> (b -> a) -> [b] -> Maybe (Odds a)
= r where
fromListOdds fr e = Nothing
r [] = Just (unfoldOdds f (xs, length xs))
r xs = Left (e x)
f ([x],_) = Right ((ys,l), fr (ys,l) % fr (zs,r), (zs,r)) where
f (xs ,n) = n `div` 2
l = n - l
r = splitAt l xs
(ys,zs)
equalOdds :: [a] -> Maybe (Odds a)
= fromListOdds (fromIntegral . snd) id
equalOdds
fromDistrib :: [(a,Integer)] -> Maybe (Odds a)
= fromListOdds (sum . map snd . fst) fst fromDistrib
What’s really nice about this version is the fact that the old append
is just the Choice
constructor, leaving the instances to be really nice:
flatten :: Odds (Odds a) -> Odds a
= foldOdds Choice id
flatten
instance Applicative Odds where
pure = Certain
<*> xs = flatten (fmap (<$> xs) fs)
fs
instance Monad Odds where
>>= f = flatten (f <$> x) x
Finally, as a bonus, to remove duplicates:
lcd :: Foldable f => f Rational -> Integer
= foldl' (\a e -> lcm a (denominator e)) 1
lcd
toDistrib :: Odds a -> [(a,Integer)]
= factorOut . foldOdds f b where
toDistrib = [(x,1)]
b x = (map.fmap) (n%t*) l ++ (map.fmap) (d%t*) r where
f l p r = numerator p
n = denominator p
d = n + d
t = (map.fmap) (numerator . (lcd'*)) xs where
factorOut xs = fromIntegral . lcd . map snd $ xs
lcd'
counts :: (Ord a, Num n) => [(a,n)] -> [(a,n)]
=
counts .
Map.assocs +)
Map.fromListWith (
compress :: Ord a => Odds a -> Odds a
= let Just ys = (fromDistrib . counts . toDistrib) xs in ys compress xs
After reading yet more on this, I found that the main issue with the monad is its performance. Two articles in particular: Larsen (2011), and Ścibior, Ghahramani, and Gordon (2015), refer to a GADT implementation of the monad which maximises laziness.
References
Erwig, Martin, and Steve Kollmansberger. 2006. “Functional Pearls: Probabilistic Functional Programming in Haskell.” Journal of Functional Programming 16 (1): 21–34. doi:10.1017/S0956796805005721.
Kidd, Eric. 2007. “Build Your Own Probability Monads.”
Larsen, Ken Friis. 2011. “Memory Efficient Implementation of Probability Monads.”
Ścibior, Adam, Zoubin Ghahramani, and Andrew D. Gordon. 2015. “Practical Probabilistic Programming with Monads.” In Proceedings of the 2015 ACM SIGPLAN Symposium on Haskell, 50:165–176. Haskell ’15. New York, NY, USA: ACM. doi:10.1145/2804302.2804317.