{-# LANGUAGE RankNTypes #-}

-- |
-- Module      :  Mcmc.Proposal.Slide
-- Description :  Additive proposals
-- Copyright   :  (c) Dominik Schrempf 2021
-- 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.
slideSimple :: Mean -> StandardDeviation -> TuningParameter -> ProposalSimple Double
slideSimple :: Mean -> Mean -> Mean -> ProposalSimple Mean
slideSimple Mean
m Mean
s Mean
t =
  NormalDistribution
-> (Mean -> Mean -> Mean)
-> Maybe (Mean -> Mean)
-> Maybe (Mean -> Mean -> Jacobian)
-> ProposalSimple Mean
forall d a.
(ContDistr d, ContGen d) =>
d
-> (a -> Mean -> a)
-> Maybe (Mean -> Mean)
-> Maybe (a -> Mean -> Jacobian)
-> ProposalSimple a
genericContinuous (Mean -> Mean -> NormalDistribution
normalDistr Mean
m (Mean
s Mean -> Mean -> Mean
forall a. Num a => a -> a -> a
* Mean
t)) Mean -> Mean -> Mean
forall a. Num a => a -> a -> a
(+) ((Mean -> Mean) -> Maybe (Mean -> Mean)
forall a. a -> Maybe a
Just Mean -> Mean
forall a. Num a => a -> a
negate) Maybe (Mean -> Mean -> Jacobian)
forall a. Maybe a
Nothing

-- | Additive proposal with normally distributed kernel.
slide ::
  Mean ->
  StandardDeviation ->
  PName ->
  PWeight ->
  Tune ->
  Proposal Double
slide :: Mean -> Mean -> PName -> PWeight -> Tune -> Proposal Mean
slide Mean
m Mean
s = PDescription
-> (Mean -> ProposalSimple Mean)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal Mean
forall a.
PDescription
-> (Mean -> ProposalSimple a)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
description (Mean -> Mean -> Mean -> ProposalSimple Mean
slideSimple Mean
m Mean
s) (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]
++ Mean -> String
forall a. Show a => a -> String
show Mean
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", sd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Mean -> String
forall a. Show a => a -> String
show Mean
s

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

-- | Additive proposal with normally distributed kernel with mean zero. This
-- proposal is very fast, because the Metropolis-Hastings-Green ratio does not
-- include calculation of the forwards and backwards kernels.
slideSymmetric ::
  StandardDeviation ->
  PName ->
  PWeight ->
  Tune ->
  Proposal Double
slideSymmetric :: Mean -> PName -> PWeight -> Tune -> Proposal Mean
slideSymmetric Mean
s = PDescription
-> (Mean -> ProposalSimple Mean)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal Mean
forall a.
PDescription
-> (Mean -> ProposalSimple a)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
description (Mean -> Mean -> ProposalSimple Mean
slideSymmetricSimple Mean
s) (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]
++ Mean -> String
forall a. Show a => a -> String
show Mean
s

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

-- | Additive proposal with uniformly distributed kernel with mean zero. This
-- proposal is very 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 :: Mean -> PName -> PWeight -> Tune -> Proposal Mean
slideUniformSymmetric Mean
d = PDescription
-> (Mean -> ProposalSimple Mean)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal Mean
forall a.
PDescription
-> (Mean -> ProposalSimple a)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
description (Mean -> Mean -> ProposalSimple Mean
slideUniformSimple Mean
d) (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]
++ Mean -> String
forall a. Show a => a -> String
show Mean
d

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

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

-- | Additive proposal with 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 ->
  StandardDeviation ->
  PName ->
  PWeight ->
  Tune ->
  Proposal (Double, Double)
slideContrarily :: Mean -> Mean -> PName -> PWeight -> Tune -> Proposal (Mean, Mean)
slideContrarily Mean
m Mean
s = PDescription
-> (Mean -> ProposalSimple (Mean, Mean))
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal (Mean, Mean)
forall a.
PDescription
-> (Mean -> ProposalSimple a)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
description (Mean -> Mean -> Mean -> ProposalSimple (Mean, Mean)
slideContrarilySimple Mean
m Mean
s) (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]
++ Mean -> String
forall a. Show a => a -> String
show Mean
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", sd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Mean -> String
forall a. Show a => a -> String
show Mean
s