{-# LANGUAGE UndecidableInstances #-}
module Goal.Probability.Statistical
(
Random (Random)
, Statistical (SamplePoint)
, Sample
, realize
, initialize
, uniformInitialize
, uniformInitialize'
, Generative (sample,samplePoint)
, AbsolutelyContinuous (densities,logDensities)
, density
, logDensity
, Discrete (Cardinality,sampleSpace)
, pointSampleSpace
, expectation
, MaximumLikelihood (mle)
, LogLikelihood (logLikelihood,logLikelihoodDifferential)
) where
import Goal.Core
import Goal.Geometry
import qualified Goal.Core.Vector.Boxed as B
import qualified Goal.Core.Vector.Storable as S
import qualified Goal.Core.Vector.Generic as G
import qualified Data.List as L
import qualified System.Random.MWC as R
import Foreign.Storable
class Manifold x => Statistical x where
type SamplePoint x :: Type
type Sample x = [SamplePoint x]
newtype Random a = Random (forall s. R.Gen s -> ST s a)
realize :: Random a -> IO a
realize :: Random a -> IO a
realize (Random forall s. Gen s -> ST s a
rv) = (forall s. Gen s -> ST s a) -> IO a
forall a. (forall s. Gen s -> ST s a) -> IO a
R.withSystemRandomST forall s. Gen s -> ST s a
rv
class KnownNat (Cardinality x) => Discrete x where
type Cardinality x :: Nat
sampleSpace :: Proxy x -> Sample x
pointSampleSpace :: forall c x . Discrete x => c # x -> Sample x
pointSampleSpace :: (c # x) -> Sample x
pointSampleSpace c # x
_ = Proxy x -> Sample x
forall x. Discrete x => Proxy x -> Sample x
sampleSpace (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x)
class Statistical x => Generative c x where
samplePoint :: Point c x -> Random (SamplePoint x)
samplePoint = ([SamplePoint x] -> SamplePoint x)
-> Random [SamplePoint x] -> Random (SamplePoint x)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [SamplePoint x] -> SamplePoint x
forall a. [a] -> a
head (Random [SamplePoint x] -> Random (SamplePoint x))
-> (Point c x -> Random [SamplePoint x])
-> Point c x
-> Random (SamplePoint x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Point c x -> Random [SamplePoint x]
forall c x.
Generative c x =>
Int -> Point c x -> Random [SamplePoint x]
sample Int
1
sample :: Int -> Point c x -> Random (Sample x)
sample Int
n = Int -> Random (SamplePoint x) -> Random [SamplePoint x]
forall (m :: Type -> Type) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Random (SamplePoint x) -> Random [SamplePoint x])
-> (Point c x -> Random (SamplePoint x))
-> Point c x
-> Random [SamplePoint x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point c x -> Random (SamplePoint x)
forall c x. Generative c x => Point c x -> Random (SamplePoint x)
samplePoint
class Statistical x => AbsolutelyContinuous c x where
logDensities :: Point c x -> Sample x -> [Double]
logDensities Point c x
p = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
forall a. Floating a => a -> a
log ([Double] -> [Double])
-> (Sample x -> [Double]) -> Sample x -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point c x -> Sample x -> [Double]
forall c x.
AbsolutelyContinuous c x =>
Point c x -> Sample x -> [Double]
densities Point c x
p
densities :: Point c x -> Sample x -> [Double]
densities Point c x
p = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
forall a. Floating a => a -> a
exp ([Double] -> [Double])
-> (Sample x -> [Double]) -> Sample x -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point c x -> Sample x -> [Double]
forall c x.
AbsolutelyContinuous c x =>
Point c x -> Sample x -> [Double]
logDensities Point c x
p
logDensity :: AbsolutelyContinuous c x => Point c x -> SamplePoint x -> Double
logDensity :: Point c x -> SamplePoint x -> Double
logDensity Point c x
p = [Double] -> Double
forall a. [a] -> a
head ([Double] -> Double)
-> (SamplePoint x -> [Double]) -> SamplePoint x -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point c x -> Sample x -> [Double]
forall c x.
AbsolutelyContinuous c x =>
Point c x -> Sample x -> [Double]
logDensities Point c x
p (Sample x -> [Double])
-> (SamplePoint x -> Sample x) -> SamplePoint x -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SamplePoint x -> Sample x -> Sample x
forall a. a -> [a] -> [a]
:[])
density :: AbsolutelyContinuous c x => Point c x -> SamplePoint x -> Double
density :: Point c x -> SamplePoint x -> Double
density Point c x
p = Double -> Double
forall a. Floating a => a -> a
exp (Double -> Double)
-> (SamplePoint x -> Double) -> SamplePoint x -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point c x -> SamplePoint x -> Double
forall c x.
AbsolutelyContinuous c x =>
Point c x -> SamplePoint x -> Double
logDensity Point c x
p
expectation
:: forall c x . (AbsolutelyContinuous c x, Discrete x)
=> Point c x
-> (SamplePoint x -> Double)
-> Double
expectation :: Point c x -> (SamplePoint x -> Double) -> Double
expectation Point c x
p SamplePoint x -> Double
f =
let xs :: Sample x
xs = Proxy x -> Sample x
forall x. Discrete x => Proxy x -> Sample x
sampleSpace (Proxy x
forall k (t :: k). Proxy t
Proxy :: Proxy x)
in [Double] -> Double
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double) -> [Double] -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) (SamplePoint x -> Double
f (SamplePoint x -> Double) -> Sample x -> [Double]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Sample x
xs) (Point c x -> Sample x -> [Double]
forall c x.
AbsolutelyContinuous c x =>
Point c x -> Sample x -> [Double]
densities Point c x
p Sample x
xs)
class Statistical x => MaximumLikelihood c x where
mle :: Sample x -> c # x
class Manifold x => LogLikelihood c x s where
logLikelihood :: [s] -> c # x -> Double
logLikelihoodDifferential :: [s] -> c # x -> c #* x
initialize
:: (Manifold x, Generative d y, SamplePoint y ~ Double)
=> d # y
-> Random (c # x)
initialize :: (d # y) -> Random (c # x)
initialize d # y
q = Vector Vector (Dimension x) Double -> c # x
forall c x. Vector (Dimension x) Double -> Point c x
Point (Vector Vector (Dimension x) Double -> c # x)
-> Random (Vector Vector (Dimension x) Double) -> Random (c # x)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Random Double -> Random (Vector Vector (Dimension x) Double)
forall (n :: Nat) (m :: Type -> Type) a.
(KnownNat n, Storable a, Monad m) =>
m a -> m (Vector n a)
S.replicateM ((d # y) -> Random (SamplePoint y)
forall c x. Generative c x => Point c x -> Random (SamplePoint x)
samplePoint d # y
q)
uniformInitialize' :: Manifold x => B.Vector (Dimension x) (Double,Double) -> Random (Point c x)
uniformInitialize' :: Vector (Dimension x) (Double, Double) -> Random (Point c x)
uniformInitialize' Vector (Dimension x) (Double, Double)
bnds =
(forall s. Gen s -> ST s (Point c x)) -> Random (Point c x)
forall a. (forall s. Gen s -> ST s a) -> Random a
Random ((forall s. Gen s -> ST s (Point c x)) -> Random (Point c x))
-> (forall s. Gen s -> ST s (Point c x)) -> Random (Point c x)
forall a b. (a -> b) -> a -> b
$ \Gen s
gn -> Vector Vector (Dimension x) Double -> Point c x
forall c x. Vector (Dimension x) Double -> Point c x
Point (Vector Vector (Dimension x) Double -> Point c x)
-> (Vector Vector (Dimension x) Double
-> Vector Vector (Dimension x) Double)
-> Vector Vector (Dimension x) Double
-> Point c x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Vector (Dimension x) Double
-> Vector Vector (Dimension x) Double
forall (v :: Type -> Type) a (w :: Type -> Type) (n :: Nat).
(Vector v a, Vector w a) =>
Vector v n a -> Vector w n a
G.convert (Vector Vector (Dimension x) Double -> Point c x)
-> ST s (Vector Vector (Dimension x) Double) -> ST s (Point c x)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Double, Double) -> ST s Double)
-> Vector (Dimension x) (Double, Double)
-> ST s (Vector Vector (Dimension x) Double)
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Double, Double) -> Gen (PrimState (ST s)) -> ST s Double
forall a (m :: Type -> Type).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
`R.uniformR` Gen s
Gen (PrimState (ST s))
gn) Vector (Dimension x) (Double, Double)
bnds
uniformInitialize :: Manifold x => (Double,Double) -> Random (Point c x)
uniformInitialize :: (Double, Double) -> Random (Point c x)
uniformInitialize (Double, Double)
bnds =
(forall s. Gen s -> ST s (Point c x)) -> Random (Point c x)
forall a. (forall s. Gen s -> ST s a) -> Random a
Random ((forall s. Gen s -> ST s (Point c x)) -> Random (Point c x))
-> (forall s. Gen s -> ST s (Point c x)) -> Random (Point c x)
forall a b. (a -> b) -> a -> b
$ \Gen s
gn -> Vector Vector (Dimension x) Double -> Point c x
forall c x. Vector (Dimension x) Double -> Point c x
Point (Vector Vector (Dimension x) Double -> Point c x)
-> ST s (Vector Vector (Dimension x) Double) -> ST s (Point c x)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ST s Double -> ST s (Vector Vector (Dimension x) Double)
forall (n :: Nat) (m :: Type -> Type) a.
(KnownNat n, Storable a, Monad m) =>
m a -> m (Vector n a)
S.replicateM ((Double, Double) -> Gen (PrimState (ST s)) -> ST s Double
forall a (m :: Type -> Type).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
R.uniformR (Double, Double)
bnds Gen s
Gen (PrimState (ST s))
gn)
instance Functor Random where
fmap :: (a -> b) -> Random a -> Random b
fmap a -> b
f (Random forall s. Gen s -> ST s a
rx) =
(forall s. Gen s -> ST s b) -> Random b
forall a. (forall s. Gen s -> ST s a) -> Random a
Random ((forall s. Gen s -> ST s b) -> Random b)
-> (forall s. Gen s -> ST s b) -> Random b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> ST s a -> ST s b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ST s a -> ST s b) -> (Gen s -> ST s a) -> Gen s -> ST s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen s -> ST s a
forall s. Gen s -> ST s a
rx
instance Applicative Random where
pure :: a -> Random a
pure a
x = (forall s. Gen s -> ST s a) -> Random a
forall a. (forall s. Gen s -> ST s a) -> Random a
Random ((forall s. Gen s -> ST s a) -> Random a)
-> (forall s. Gen s -> ST s a) -> Random a
forall a b. (a -> b) -> a -> b
$ \Gen s
_ -> a -> ST s a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
x
<*> :: Random (a -> b) -> Random a -> Random b
(<*>) = Random (a -> b) -> Random a -> Random b
forall (m :: Type -> Type) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Random where
>>= :: Random a -> (a -> Random b) -> Random b
(>>=) (Random forall s. Gen s -> ST s a
rx) a -> Random b
rf =
(forall s. Gen s -> ST s b) -> Random b
forall a. (forall s. Gen s -> ST s a) -> Random a
Random ((forall s. Gen s -> ST s b) -> Random b)
-> (forall s. Gen s -> ST s b) -> Random b
forall a b. (a -> b) -> a -> b
$ \Gen s
gn -> do
a
a <- Gen s -> ST s a
forall s. Gen s -> ST s a
rx Gen s
gn
let (Random forall s. Gen s -> ST s b
rv) = a -> Random b
rf a
a
Gen s -> ST s b
forall s. Gen s -> ST s b
rv Gen s
gn
instance (Statistical x, KnownNat k, Storable (SamplePoint x))
=> Statistical (Replicated k x) where
type SamplePoint (Replicated k x) = S.Vector k (SamplePoint x)
instance (KnownNat k, Generative c x, Storable (SamplePoint x))
=> Generative c (Replicated k x) where
samplePoint :: Point c (Replicated k x) -> Random (SamplePoint (Replicated k x))
samplePoint = (Point c x -> Random (SamplePoint x))
-> Vector k (Point c x) -> Random (Vector k (SamplePoint x))
forall (m :: Type -> Type) a b (n :: Nat).
(Monad m, Storable a, Storable b) =>
(a -> m b) -> Vector n a -> m (Vector n b)
S.mapM Point c x -> Random (SamplePoint x)
forall c x. Generative c x => Point c x -> Random (SamplePoint x)
samplePoint (Vector k (Point c x) -> Random (Vector k (SamplePoint x)))
-> (Point c (Replicated k x) -> Vector k (Point c x))
-> Point c (Replicated k x)
-> Random (Vector k (SamplePoint x))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point c (Replicated k x) -> Vector k (Point c x)
forall (k :: Nat) x c.
(KnownNat k, Manifold x) =>
(c # Replicated k x) -> Vector k (c # x)
splitReplicated
instance (KnownNat k, Storable (SamplePoint x), AbsolutelyContinuous c x)
=> AbsolutelyContinuous c (Replicated k x) where
densities :: Point c (Replicated k x) -> Sample (Replicated k x) -> [Double]
densities Point c (Replicated k x)
cx Sample (Replicated k x)
sxss =
let sxss' :: [[SamplePoint x]]
sxss' = [[SamplePoint x]] -> [[SamplePoint x]]
forall a. [[a]] -> [[a]]
L.transpose ([[SamplePoint x]] -> [[SamplePoint x]])
-> [[SamplePoint x]] -> [[SamplePoint x]]
forall a b. (a -> b) -> a -> b
$ Vector k (SamplePoint x) -> [SamplePoint x]
forall a (n :: Nat). Storable a => Vector n a -> [a]
S.toList (Vector k (SamplePoint x) -> [SamplePoint x])
-> [Vector k (SamplePoint x)] -> [[SamplePoint x]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Vector k (SamplePoint x)]
Sample (Replicated k x)
sxss
cxs :: [c # x]
cxs = Vector k (c # x) -> [c # x]
forall a (n :: Nat). Storable a => Vector n a -> [a]
S.toList (Vector k (c # x) -> [c # x]) -> Vector k (c # x) -> [c # x]
forall a b. (a -> b) -> a -> b
$ Point c (Replicated k x) -> Vector k (c # x)
forall (k :: Nat) x c.
(KnownNat k, Manifold x) =>
(c # Replicated k x) -> Vector k (c # x)
splitReplicated Point c (Replicated k x)
cx
dnss :: [[Double]]
dnss = ((c # x) -> [SamplePoint x] -> [Double])
-> [c # x] -> [[SamplePoint x]] -> [[Double]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (c # x) -> [SamplePoint x] -> [Double]
forall c x.
AbsolutelyContinuous c x =>
Point c x -> Sample x -> [Double]
densities [c # x]
cxs [[SamplePoint x]]
sxss'
in [Double] -> Double
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
product ([Double] -> Double) -> [[Double]] -> [Double]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Double]] -> [[Double]]
forall a. [[a]] -> [[a]]
L.transpose [[Double]]
dnss
instance (KnownNat k, LogLikelihood c x s, Storable s)
=> LogLikelihood c (Replicated k x) (S.Vector k s) where
logLikelihood :: [Vector k s] -> (c # Replicated k x) -> Double
logLikelihood [Vector k s]
cxs c # Replicated k x
ps = Vector k Double -> Double
forall a (n :: Nat). (Storable a, Num a) => Vector n a -> a
S.sum (Vector k Double -> Double)
-> (Vector k (c # x) -> Vector k Double)
-> Vector k (c # x)
-> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Finite k -> (c # x) -> Double)
-> Vector k (c # x) -> Vector k Double
forall a b (n :: Nat).
(Storable a, Storable b) =>
(Finite n -> a -> b) -> Vector n a -> Vector n b
S.imap Finite k -> (c # x) -> Double
subLogLikelihood (Vector k (c # x) -> Double) -> Vector k (c # x) -> Double
forall a b. (a -> b) -> a -> b
$ (c # Replicated k x) -> Vector k (c # x)
forall (k :: Nat) x c.
(KnownNat k, Manifold x) =>
(c # Replicated k x) -> Vector k (c # x)
splitReplicated c # Replicated k x
ps
where subLogLikelihood :: Finite k -> (c # x) -> Double
subLogLikelihood Finite k
fn = [s] -> (c # x) -> Double
forall c x s. LogLikelihood c x s => [s] -> (c # x) -> Double
logLikelihood ((Vector k s -> Finite k -> s) -> Finite k -> Vector k s -> s
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vector k s -> Finite k -> s
forall (n :: Nat) a. Storable a => Vector n a -> Finite n -> a
S.index Finite k
fn (Vector k s -> s) -> [Vector k s] -> [s]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Vector k s]
cxs)
logLikelihoodDifferential :: [Vector k s] -> (c # Replicated k x) -> c #* Replicated k x
logLikelihoodDifferential [Vector k s]
cxs c # Replicated k x
ps =
Vector k (Dual c # x) -> c #* Replicated k x
forall (k :: Nat) x c.
(KnownNat k, Manifold x) =>
Vector k (c # x) -> c # Replicated k x
joinReplicated (Vector k (Dual c # x) -> c #* Replicated k x)
-> (Vector k (c # x) -> Vector k (Dual c # x))
-> Vector k (c # x)
-> c #* Replicated k x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Finite k -> (c # x) -> Dual c # x)
-> Vector k (c # x) -> Vector k (Dual c # x)
forall a b (n :: Nat).
(Storable a, Storable b) =>
(Finite n -> a -> b) -> Vector n a -> Vector n b
S.imap Finite k -> (c # x) -> Dual c # x
subLogLikelihoodDifferential (Vector k (c # x) -> c #* Replicated k x)
-> Vector k (c # x) -> c #* Replicated k x
forall a b. (a -> b) -> a -> b
$ (c # Replicated k x) -> Vector k (c # x)
forall (k :: Nat) x c.
(KnownNat k, Manifold x) =>
(c # Replicated k x) -> Vector k (c # x)
splitReplicated c # Replicated k x
ps
where subLogLikelihoodDifferential :: Finite k -> (c # x) -> Dual c # x
subLogLikelihoodDifferential Finite k
fn =
[s] -> (c # x) -> Dual c # x
forall c x s. LogLikelihood c x s => [s] -> (c # x) -> c #* x
logLikelihoodDifferential ((Vector k s -> Finite k -> s) -> Finite k -> Vector k s -> s
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vector k s -> Finite k -> s
forall (n :: Nat) a. Storable a => Vector n a -> Finite n -> a
S.index Finite k
fn (Vector k s -> s) -> [Vector k s] -> [s]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Vector k s]
cxs)
instance (Statistical x) => Statistical [x] where
type SamplePoint [x] = [SamplePoint x]
instance (Statistical x, Statistical y)
=> Statistical (x,y) where
type SamplePoint (x,y) = (SamplePoint x, SamplePoint y)
instance (Generative c x, Generative c y) => Generative c (x,y) where
samplePoint :: Point c (x, y) -> Random (SamplePoint (x, y))
samplePoint Point c (x, y)
pmn = do
let (Point c x
pm,Point c y
pn) = Point c (x, y) -> (c # First (x, y), c # Second (x, y))
forall z c. Product z => (c # z) -> (c # First z, c # Second z)
split Point c (x, y)
pmn
SamplePoint x
xm <- Point c x -> Random (SamplePoint x)
forall c x. Generative c x => Point c x -> Random (SamplePoint x)
samplePoint Point c x
pm
SamplePoint y
xn <- Point c y -> Random (SamplePoint y)
forall c x. Generative c x => Point c x -> Random (SamplePoint x)
samplePoint Point c y
pn
(SamplePoint x, SamplePoint y)
-> Random (SamplePoint x, SamplePoint y)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SamplePoint x
xm,SamplePoint y
xn)
instance (AbsolutelyContinuous c x, AbsolutelyContinuous c y)
=> AbsolutelyContinuous c (x,y) where
densities :: Point c (x, y) -> Sample (x, y) -> [Double]
densities Point c (x, y)
cxy Sample (x, y)
sxys =
let (Point c x
cx,Point c y
cy) = Point c (x, y) -> (c # First (x, y), c # Second (x, y))
forall z c. Product z => (c # z) -> (c # First z, c # Second z)
split Point c (x, y)
cxy
([SamplePoint x]
sxs,[SamplePoint y]
sys) = [(SamplePoint x, SamplePoint y)]
-> ([SamplePoint x], [SamplePoint y])
forall a b. [(a, b)] -> ([a], [b])
unzip [(SamplePoint x, SamplePoint y)]
Sample (x, y)
sxys
in (Double -> Double -> Double) -> [Double] -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) (Point c x -> [SamplePoint x] -> [Double]
forall c x.
AbsolutelyContinuous c x =>
Point c x -> Sample x -> [Double]
densities Point c x
cx [SamplePoint x]
sxs) ([Double] -> [Double]) -> [Double] -> [Double]
forall a b. (a -> b) -> a -> b
$ Point c y -> [SamplePoint y] -> [Double]
forall c x.
AbsolutelyContinuous c x =>
Point c x -> Sample x -> [Double]
densities Point c y
cy [SamplePoint y]
sys