{-# LANGUAGE RankNTypes #-}

-- |
-- Module      :  Mcmc.Proposal.Slide
-- Description :  Additive proposals
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Wed May  6 10:59:13 2020.
module Mcmc.Proposal.Slide
  ( slide,
    slideSymmetric,
    slideUniformSymmetric,
    slideContrarily,
  )
where

import Mcmc.Proposal
import Mcmc.Proposal.Generic
import Mcmc.Statistics.Types
import Statistics.Distribution.Normal
import Statistics.Distribution.Uniform

-- The actual proposal with tuning parameter.
slidePFunction :: Mean Double -> StandardDeviation Double -> TuningParameter -> PFunction Double
slidePFunction :: Double -> Double -> Double -> PFunction Double
slidePFunction Double
m Double
s Double
t =
  NormalDistribution
-> (Double -> Double -> Double)
-> Maybe (Double -> Double)
-> Maybe (Double -> Double -> Jacobian)
-> PFunction Double
forall d a.
(ContDistr d, ContGen d) =>
d
-> (a -> Double -> a)
-> Maybe (Double -> Double)
-> Maybe (a -> Double -> Jacobian)
-> PFunction a
genericContinuous (Double -> Double -> NormalDistribution
normalDistr Double
m (Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t)) Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) ((Double -> Double) -> Maybe (Double -> Double)
forall a. a -> Maybe a
Just Double -> Double
forall a. Num a => a -> a
negate) Maybe (Double -> Double -> Jacobian)
forall a. Maybe a
Nothing

-- | Additive proposal.
--
-- A normal distribution is used to sample the addend.
slide ::
  Mean Double ->
  StandardDeviation Double ->
  PName ->
  PWeight ->
  Tune ->
  Proposal Double
slide :: Double -> Double -> PName -> PWeight -> Tune -> Proposal Double
slide Double
m Double
s = PDescription
-> (Double -> PFunction Double)
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal Double
forall a.
PDescription
-> (Double -> PFunction a)
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
description (Double -> Double -> Double -> PFunction Double
slidePFunction Double
m Double
s) PSpeed
PFast (Int -> PDimension
PDimension Int
1)
  where
    description :: PDescription
description = String -> PDescription
PDescription (String -> PDescription) -> String -> PDescription
forall a b. (a -> b) -> a -> b
$ String
"Slide; mean: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", sd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
s

-- The actual proposal with tuning parameter.
slideSymmetricPFunction :: StandardDeviation Double -> TuningParameter -> PFunction Double
slideSymmetricPFunction :: Double -> Double -> PFunction Double
slideSymmetricPFunction Double
s Double
t =
  NormalDistribution
-> (Double -> Double -> Double)
-> Maybe (Double -> Double)
-> Maybe (Double -> Double -> Jacobian)
-> PFunction Double
forall d a.
(ContDistr d, ContGen d) =>
d
-> (a -> Double -> a)
-> Maybe (Double -> Double)
-> Maybe (a -> Double -> Jacobian)
-> PFunction a
genericContinuous (Double -> Double -> NormalDistribution
normalDistr Double
0.0 (Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t)) Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Maybe (Double -> Double)
forall a. Maybe a
Nothing Maybe (Double -> Double -> Jacobian)
forall a. Maybe a
Nothing

-- | See 'slide'.
--
-- Use a normal distribution with mean zero. This proposal is fast, because the
-- Metropolis-Hastings-Green ratio does not include calculation of the forwards
-- and backwards kernels.
slideSymmetric ::
  StandardDeviation Double ->
  PName ->
  PWeight ->
  Tune ->
  Proposal Double
slideSymmetric :: Double -> PName -> PWeight -> Tune -> Proposal Double
slideSymmetric Double
s = PDescription
-> (Double -> PFunction Double)
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal Double
forall a.
PDescription
-> (Double -> PFunction a)
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
description (Double -> Double -> PFunction Double
slideSymmetricPFunction Double
s) PSpeed
PFast (Int -> PDimension
PDimension Int
1)
  where
    description :: PDescription
description = String -> PDescription
PDescription (String -> PDescription) -> String -> PDescription
forall a b. (a -> b) -> a -> b
$ String
"Slide symmetric; sd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
s

-- The actual proposal with tuning parameter.
slideUniformPFunction :: Size -> TuningParameter -> PFunction Double
slideUniformPFunction :: Double -> Double -> PFunction Double
slideUniformPFunction Double
d Double
t =
  UniformDistribution
-> (Double -> Double -> Double)
-> Maybe (Double -> Double)
-> Maybe (Double -> Double -> Jacobian)
-> PFunction Double
forall d a.
(ContDistr d, ContGen d) =>
d
-> (a -> Double -> a)
-> Maybe (Double -> Double)
-> Maybe (a -> Double -> Jacobian)
-> PFunction a
genericContinuous (Double -> Double -> UniformDistribution
uniformDistr (-Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
d) (Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
d)) Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Maybe (Double -> Double)
forall a. Maybe a
Nothing Maybe (Double -> Double -> Jacobian)
forall a. Maybe a
Nothing

-- | See 'slide'.
--
-- Use a uniformly distributed kernel with mean zero. This proposal is fast,
-- because the Metropolis-Hastings-Green ratio does not include calculation of
-- the forwards and backwards kernels.
slideUniformSymmetric ::
  Size ->
  PName ->
  PWeight ->
  Tune ->
  Proposal Double
slideUniformSymmetric :: Double -> PName -> PWeight -> Tune -> Proposal Double
slideUniformSymmetric Double
d = PDescription
-> (Double -> PFunction Double)
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal Double
forall a.
PDescription
-> (Double -> PFunction a)
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
description (Double -> Double -> PFunction Double
slideUniformPFunction Double
d) PSpeed
PFast (Int -> PDimension
PDimension Int
1)
  where
    description :: PDescription
description = String -> PDescription
PDescription (String -> PDescription) -> String -> PDescription
forall a b. (a -> b) -> a -> b
$ String
"Slide uniform symmetric; delta: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
d

contra :: (Double, Double) -> Double -> (Double, Double)
contra :: (Double, Double) -> Double -> (Double, Double)
contra (Double
x, Double
y) Double
u = (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
u, Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
u)

slideContrarilyPFunction ::
  Mean Double ->
  StandardDeviation Double ->
  TuningParameter ->
  PFunction (Double, Double)
slideContrarilyPFunction :: Double -> Double -> Double -> PFunction (Double, Double)
slideContrarilyPFunction Double
m Double
s Double
t =
  NormalDistribution
-> ((Double, Double) -> Double -> (Double, Double))
-> Maybe (Double -> Double)
-> Maybe ((Double, Double) -> Double -> Jacobian)
-> PFunction (Double, Double)
forall d a.
(ContDistr d, ContGen d) =>
d
-> (a -> Double -> a)
-> Maybe (Double -> Double)
-> Maybe (a -> Double -> Jacobian)
-> PFunction a
genericContinuous (Double -> Double -> NormalDistribution
normalDistr Double
m (Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t)) (Double, Double) -> Double -> (Double, Double)
contra ((Double -> Double) -> Maybe (Double -> Double)
forall a. a -> Maybe a
Just Double -> Double
forall a. Num a => a -> a
negate) Maybe ((Double, Double) -> Double -> Jacobian)
forall a. Maybe a
Nothing

-- | See 'slide'.
--
-- Use a normally distributed kernel.
--
-- The two values are slid contrarily so that their sum stays constant. Contrary
-- proposals are useful when parameters are confounded.
slideContrarily ::
  Mean Double ->
  StandardDeviation Double ->
  PName ->
  PWeight ->
  Tune ->
  Proposal (Double, Double)
slideContrarily :: Double
-> Double -> PName -> PWeight -> Tune -> Proposal (Double, Double)
slideContrarily Double
m Double
s = PDescription
-> (Double -> PFunction (Double, Double))
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal (Double, Double)
forall a.
PDescription
-> (Double -> PFunction a)
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
description (Double -> Double -> Double -> PFunction (Double, Double)
slideContrarilyPFunction Double
m Double
s) PSpeed
PFast (Int -> PDimension
PDimension Int
2)
  where
    description :: PDescription
description = String -> PDescription
PDescription (String -> PDescription) -> String -> PDescription
forall a b. (a -> b) -> a -> b
$ String
"Slide contrarily; mean: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", sd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
s