{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Mcmc.Proposal
(
PName (..),
PDescription (..),
PWeight (fromPWeight),
pWeight,
PDimension (..),
Proposal (..),
KernelRatio,
Jacobian,
JacobianFunction,
(@~),
liftProposal,
liftProposalWith,
ProposalSimple,
Tuner (..),
Tune (..),
defaultTuningFunction,
createProposal,
TuningParameter,
AuxiliaryTuningParameters,
tuningParameterMin,
tuningParameterMax,
tuneWithTuningParameters,
tuneWithChainParameters,
getOptimalRate,
proposalHeader,
summarizeProposal,
)
where
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Double.Conversion.ByteString as BC
import Data.Function
import qualified Data.Vector as VB
import Lens.Micro
import Lens.Micro.Extras
import Mcmc.Acceptance
import Mcmc.Internal.ByteString
import Numeric.Log hiding (sum)
import System.Random.MWC
newtype PName = PName {PName -> String
fromPName :: String}
deriving (Int -> PName -> ShowS
[PName] -> ShowS
PName -> String
(Int -> PName -> ShowS)
-> (PName -> String) -> ([PName] -> ShowS) -> Show PName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PName] -> ShowS
$cshowList :: [PName] -> ShowS
show :: PName -> String
$cshow :: PName -> String
showsPrec :: Int -> PName -> ShowS
$cshowsPrec :: Int -> PName -> ShowS
Show, PName -> PName -> Bool
(PName -> PName -> Bool) -> (PName -> PName -> Bool) -> Eq PName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PName -> PName -> Bool
$c/= :: PName -> PName -> Bool
== :: PName -> PName -> Bool
$c== :: PName -> PName -> Bool
Eq, Eq PName
Eq PName
-> (PName -> PName -> Ordering)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> Bool)
-> (PName -> PName -> PName)
-> (PName -> PName -> PName)
-> Ord PName
PName -> PName -> Bool
PName -> PName -> Ordering
PName -> PName -> PName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PName -> PName -> PName
$cmin :: PName -> PName -> PName
max :: PName -> PName -> PName
$cmax :: PName -> PName -> PName
>= :: PName -> PName -> Bool
$c>= :: PName -> PName -> Bool
> :: PName -> PName -> Bool
$c> :: PName -> PName -> Bool
<= :: PName -> PName -> Bool
$c<= :: PName -> PName -> Bool
< :: PName -> PName -> Bool
$c< :: PName -> PName -> Bool
compare :: PName -> PName -> Ordering
$ccompare :: PName -> PName -> Ordering
$cp1Ord :: Eq PName
Ord)
deriving (Semigroup PName
PName
Semigroup PName
-> PName
-> (PName -> PName -> PName)
-> ([PName] -> PName)
-> Monoid PName
[PName] -> PName
PName -> PName -> PName
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [PName] -> PName
$cmconcat :: [PName] -> PName
mappend :: PName -> PName -> PName
$cmappend :: PName -> PName -> PName
mempty :: PName
$cmempty :: PName
$cp1Monoid :: Semigroup PName
Monoid, b -> PName -> PName
NonEmpty PName -> PName
PName -> PName -> PName
(PName -> PName -> PName)
-> (NonEmpty PName -> PName)
-> (forall b. Integral b => b -> PName -> PName)
-> Semigroup PName
forall b. Integral b => b -> PName -> PName
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> PName -> PName
$cstimes :: forall b. Integral b => b -> PName -> PName
sconcat :: NonEmpty PName -> PName
$csconcat :: NonEmpty PName -> PName
<> :: PName -> PName -> PName
$c<> :: PName -> PName -> PName
Semigroup) via String
newtype PDescription = PDescription {PDescription -> String
fromPDescription :: String}
deriving (Int -> PDescription -> ShowS
[PDescription] -> ShowS
PDescription -> String
(Int -> PDescription -> ShowS)
-> (PDescription -> String)
-> ([PDescription] -> ShowS)
-> Show PDescription
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PDescription] -> ShowS
$cshowList :: [PDescription] -> ShowS
show :: PDescription -> String
$cshow :: PDescription -> String
showsPrec :: Int -> PDescription -> ShowS
$cshowsPrec :: Int -> PDescription -> ShowS
Show, PDescription -> PDescription -> Bool
(PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> Bool) -> Eq PDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PDescription -> PDescription -> Bool
$c/= :: PDescription -> PDescription -> Bool
== :: PDescription -> PDescription -> Bool
$c== :: PDescription -> PDescription -> Bool
Eq, Eq PDescription
Eq PDescription
-> (PDescription -> PDescription -> Ordering)
-> (PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> Bool)
-> (PDescription -> PDescription -> PDescription)
-> (PDescription -> PDescription -> PDescription)
-> Ord PDescription
PDescription -> PDescription -> Bool
PDescription -> PDescription -> Ordering
PDescription -> PDescription -> PDescription
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PDescription -> PDescription -> PDescription
$cmin :: PDescription -> PDescription -> PDescription
max :: PDescription -> PDescription -> PDescription
$cmax :: PDescription -> PDescription -> PDescription
>= :: PDescription -> PDescription -> Bool
$c>= :: PDescription -> PDescription -> Bool
> :: PDescription -> PDescription -> Bool
$c> :: PDescription -> PDescription -> Bool
<= :: PDescription -> PDescription -> Bool
$c<= :: PDescription -> PDescription -> Bool
< :: PDescription -> PDescription -> Bool
$c< :: PDescription -> PDescription -> Bool
compare :: PDescription -> PDescription -> Ordering
$ccompare :: PDescription -> PDescription -> Ordering
$cp1Ord :: Eq PDescription
Ord)
newtype PWeight = PWeight {PWeight -> Int
fromPWeight :: Int}
deriving (Int -> PWeight -> ShowS
[PWeight] -> ShowS
PWeight -> String
(Int -> PWeight -> ShowS)
-> (PWeight -> String) -> ([PWeight] -> ShowS) -> Show PWeight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWeight] -> ShowS
$cshowList :: [PWeight] -> ShowS
show :: PWeight -> String
$cshow :: PWeight -> String
showsPrec :: Int -> PWeight -> ShowS
$cshowsPrec :: Int -> PWeight -> ShowS
Show, PWeight -> PWeight -> Bool
(PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> Bool) -> Eq PWeight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PWeight -> PWeight -> Bool
$c/= :: PWeight -> PWeight -> Bool
== :: PWeight -> PWeight -> Bool
$c== :: PWeight -> PWeight -> Bool
Eq, Eq PWeight
Eq PWeight
-> (PWeight -> PWeight -> Ordering)
-> (PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> Bool)
-> (PWeight -> PWeight -> PWeight)
-> (PWeight -> PWeight -> PWeight)
-> Ord PWeight
PWeight -> PWeight -> Bool
PWeight -> PWeight -> Ordering
PWeight -> PWeight -> PWeight
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PWeight -> PWeight -> PWeight
$cmin :: PWeight -> PWeight -> PWeight
max :: PWeight -> PWeight -> PWeight
$cmax :: PWeight -> PWeight -> PWeight
>= :: PWeight -> PWeight -> Bool
$c>= :: PWeight -> PWeight -> Bool
> :: PWeight -> PWeight -> Bool
$c> :: PWeight -> PWeight -> Bool
<= :: PWeight -> PWeight -> Bool
$c<= :: PWeight -> PWeight -> Bool
< :: PWeight -> PWeight -> Bool
$c< :: PWeight -> PWeight -> Bool
compare :: PWeight -> PWeight -> Ordering
$ccompare :: PWeight -> PWeight -> Ordering
$cp1Ord :: Eq PWeight
Ord)
pWeight :: Int -> PWeight
pWeight :: Int -> PWeight
pWeight Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> PWeight
forall a. HasCallStack => String -> a
error String
"pWeight: Proposal weight is zero or negative."
| Bool
otherwise = Int -> PWeight
PWeight Int
n
data PDimension
= PDimension Int
| PDimensionUnknown
|
PSpecial Int Double
data Proposal a = Proposal
{
Proposal a -> PName
prName :: PName,
Proposal a -> PDescription
prDescription :: PDescription,
Proposal a -> PDimension
prDimension :: PDimension,
Proposal a -> PWeight
prWeight :: PWeight,
Proposal a -> ProposalSimple a
prSimple :: ProposalSimple a,
Proposal a -> Maybe (Tuner a)
prTuner :: Maybe (Tuner a)
}
instance Eq (Proposal a) where
Proposal a
m == :: Proposal a -> Proposal a -> Bool
== Proposal a
n = Proposal a -> PName
forall a. Proposal a -> PName
prName Proposal a
m PName -> PName -> Bool
forall a. Eq a => a -> a -> Bool
== Proposal a -> PName
forall a. Proposal a -> PName
prName Proposal a
n Bool -> Bool -> Bool
&& Proposal a -> PDescription
forall a. Proposal a -> PDescription
prDescription Proposal a
m PDescription -> PDescription -> Bool
forall a. Eq a => a -> a -> Bool
== Proposal a -> PDescription
forall a. Proposal a -> PDescription
prDescription Proposal a
n
instance Ord (Proposal a) where
compare :: Proposal a -> Proposal a -> Ordering
compare = (PDescription, PName, PWeight)
-> (PDescription, PName, PWeight) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((PDescription, PName, PWeight)
-> (PDescription, PName, PWeight) -> Ordering)
-> (Proposal a -> (PDescription, PName, PWeight))
-> Proposal a
-> Proposal a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\Proposal a
p -> (Proposal a -> PDescription
forall a. Proposal a -> PDescription
prDescription Proposal a
p, Proposal a -> PName
forall a. Proposal a -> PName
prName Proposal a
p, Proposal a -> PWeight
forall a. Proposal a -> PWeight
prWeight Proposal a
p))
type KernelRatio = Log Double
type Jacobian = Log Double
type JacobianFunction a = a -> Jacobian
infixl 7 @~
(@~) :: Lens' b a -> Proposal a -> Proposal b
@~ :: Lens' b a -> Proposal a -> Proposal b
(@~) = Lens' b a -> Proposal a -> Proposal b
forall b a. Lens' b a -> Proposal a -> Proposal b
liftProposal
liftProposal :: Lens' b a -> Proposal a -> Proposal b
liftProposal :: Lens' b a -> Proposal a -> Proposal b
liftProposal = JacobianFunction b -> Lens' b a -> Proposal a -> Proposal b
forall b a.
JacobianFunction b -> Lens' b a -> Proposal a -> Proposal b
liftProposalWith (Jacobian -> JacobianFunction b
forall a b. a -> b -> a
const Jacobian
1.0)
liftProposalWith :: JacobianFunction b -> Lens' b a -> Proposal a -> Proposal b
liftProposalWith :: JacobianFunction b -> Lens' b a -> Proposal a -> Proposal b
liftProposalWith JacobianFunction b
jf Lens' b a
l (Proposal PName
n PDescription
r PDimension
d PWeight
w ProposalSimple a
s Maybe (Tuner a)
t) =
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple b
-> Maybe (Tuner b)
-> Proposal b
forall a.
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PDimension
d PWeight
w (JacobianFunction b
-> Lens' b a -> ProposalSimple a -> ProposalSimple b
forall b a.
JacobianFunction b
-> Lens' b a -> ProposalSimple a -> ProposalSimple b
liftProposalSimple JacobianFunction b
jf Lens' b a
l ProposalSimple a
s) (JacobianFunction b -> Lens' b a -> Tuner a -> Tuner b
forall b a. JacobianFunction b -> Lens' b a -> Tuner a -> Tuner b
liftTuner JacobianFunction b
jf Lens' b a
l (Tuner a -> Tuner b) -> Maybe (Tuner a) -> Maybe (Tuner b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Tuner a)
t)
type ProposalSimple a = a -> GenIO -> IO (a, KernelRatio, Jacobian)
liftProposalSimple :: JacobianFunction b -> Lens' b a -> ProposalSimple a -> ProposalSimple b
liftProposalSimple :: JacobianFunction b
-> Lens' b a -> ProposalSimple a -> ProposalSimple b
liftProposalSimple JacobianFunction b
jf Lens' b a
l ProposalSimple a
s = b -> Gen RealWorld -> IO (b, Jacobian, Jacobian)
ProposalSimple b
s'
where
s' :: b -> Gen RealWorld -> IO (b, Jacobian, Jacobian)
s' b
y Gen RealWorld
g = do
(a
x', Jacobian
r, Jacobian
j) <- ProposalSimple a
s (b
y b -> Getting a b a -> a
forall s a. s -> Getting a s a -> a
^. Getting a b a
Lens' b a
l) Gen RealWorld
Gen (PrimState IO)
g
let y' :: b
y' = ASetter b b a a -> a -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter b b a a
Lens' b a
l a
x' b
y
jxy :: Jacobian
jxy = JacobianFunction b
jf b
y
jyx :: Jacobian
jyx = JacobianFunction b
jf b
y'
j' :: Jacobian
j' = Jacobian
j Jacobian -> Jacobian -> Jacobian
forall a. Num a => a -> a -> a
* Jacobian
jyx Jacobian -> Jacobian -> Jacobian
forall a. Fractional a => a -> a -> a
/ Jacobian
jxy
(b, Jacobian, Jacobian) -> IO (b, Jacobian, Jacobian)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
y', Jacobian
r, Jacobian
j')
data Tuner a = Tuner
{ Tuner a -> TuningParameter
tGetTuningParameter :: TuningParameter,
Tuner a -> TuningParameter -> TuningParameter -> TuningParameter
tComputeTuningParameter :: AcceptanceRate -> TuningParameter -> TuningParameter,
Tuner a -> AuxiliaryTuningParameters
tGetAuxiliaryTuningParameters :: AuxiliaryTuningParameters,
Tuner a
-> Vector a
-> AuxiliaryTuningParameters
-> AuxiliaryTuningParameters
tComputeAuxiliaryTuningParameters ::
VB.Vector a ->
AuxiliaryTuningParameters ->
AuxiliaryTuningParameters,
Tuner a
-> TuningParameter
-> AuxiliaryTuningParameters
-> Either String (ProposalSimple a)
tGetSimpleProposal ::
TuningParameter ->
AuxiliaryTuningParameters ->
Either String (ProposalSimple a)
}
liftTuner :: JacobianFunction b -> Lens' b a -> Tuner a -> Tuner b
liftTuner :: JacobianFunction b -> Lens' b a -> Tuner a -> Tuner b
liftTuner JacobianFunction b
jf Lens' b a
l (Tuner TuningParameter
p TuningParameter -> TuningParameter -> TuningParameter
fP AuxiliaryTuningParameters
ps Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fPs TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a)
g) = TuningParameter
-> (TuningParameter -> TuningParameter -> TuningParameter)
-> AuxiliaryTuningParameters
-> (Vector b
-> AuxiliaryTuningParameters -> AuxiliaryTuningParameters)
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple b))
-> Tuner b
forall a.
TuningParameter
-> (TuningParameter -> TuningParameter -> TuningParameter)
-> AuxiliaryTuningParameters
-> (Vector a
-> AuxiliaryTuningParameters -> AuxiliaryTuningParameters)
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a))
-> Tuner a
Tuner TuningParameter
p TuningParameter -> TuningParameter -> TuningParameter
fP AuxiliaryTuningParameters
ps Vector b -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fPs' TuningParameter
-> AuxiliaryTuningParameters
-> Either String (b -> Gen RealWorld -> IO (b, Jacobian, Jacobian))
TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple b)
g'
where
fPs' :: Vector b -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fPs' = Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fPs (Vector a
-> AuxiliaryTuningParameters -> AuxiliaryTuningParameters)
-> (Vector b -> Vector a)
-> Vector b
-> AuxiliaryTuningParameters
-> AuxiliaryTuningParameters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a) -> Vector b -> Vector a
forall a b. (a -> b) -> Vector a -> Vector b
VB.map (Getting a b a -> b -> a
forall a s. Getting a s a -> s -> a
view Getting a b a
Lens' b a
l)
g' :: TuningParameter
-> AuxiliaryTuningParameters
-> Either String (b -> Gen RealWorld -> IO (b, Jacobian, Jacobian))
g' TuningParameter
x AuxiliaryTuningParameters
xs = JacobianFunction b
-> Lens' b a -> ProposalSimple a -> ProposalSimple b
forall b a.
JacobianFunction b
-> Lens' b a -> ProposalSimple a -> ProposalSimple b
liftProposalSimple JacobianFunction b
jf Lens' b a
l ((a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
-> b -> Gen RealWorld -> IO (b, Jacobian, Jacobian))
-> Either String (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
-> Either String (b -> Gen RealWorld -> IO (b, Jacobian, Jacobian))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a)
g TuningParameter
x AuxiliaryTuningParameters
xs
data Tune = Tune | NoTune
deriving (Int -> Tune -> ShowS
[Tune] -> ShowS
Tune -> String
(Int -> Tune -> ShowS)
-> (Tune -> String) -> ([Tune] -> ShowS) -> Show Tune
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tune] -> ShowS
$cshowList :: [Tune] -> ShowS
show :: Tune -> String
$cshow :: Tune -> String
showsPrec :: Int -> Tune -> ShowS
$cshowsPrec :: Int -> Tune -> ShowS
Show, Tune -> Tune -> Bool
(Tune -> Tune -> Bool) -> (Tune -> Tune -> Bool) -> Eq Tune
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tune -> Tune -> Bool
$c/= :: Tune -> Tune -> Bool
== :: Tune -> Tune -> Bool
$c== :: Tune -> Tune -> Bool
Eq)
type TuningParameter = Double
type AuxiliaryTuningParameters = VB.Vector TuningParameter
defaultTuningFunction ::
PDimension ->
AcceptanceRate ->
TuningParameter ->
TuningParameter
defaultTuningFunction :: PDimension -> TuningParameter -> TuningParameter -> TuningParameter
defaultTuningFunction PDimension
d TuningParameter
r TuningParameter
t = let rO :: TuningParameter
rO = PDimension -> TuningParameter
getOptimalRate PDimension
d in TuningParameter -> TuningParameter
forall a. Floating a => a -> a
exp (TuningParameter
2 TuningParameter -> TuningParameter -> TuningParameter
forall a. Num a => a -> a -> a
* (TuningParameter
r TuningParameter -> TuningParameter -> TuningParameter
forall a. Num a => a -> a -> a
- TuningParameter
rO)) TuningParameter -> TuningParameter -> TuningParameter
forall a. Num a => a -> a -> a
* TuningParameter
t
noAuxiliaryTuningFunction :: VB.Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
noAuxiliaryTuningFunction :: Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
noAuxiliaryTuningFunction Vector a
_ AuxiliaryTuningParameters
ts = AuxiliaryTuningParameters
ts
createProposal ::
PDescription ->
(TuningParameter -> ProposalSimple a) ->
PDimension ->
PName ->
PWeight ->
Tune ->
Proposal a
createProposal :: PDescription
-> (TuningParameter -> ProposalSimple a)
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
r TuningParameter -> ProposalSimple a
f PDimension
d PName
n PWeight
w Tune
Tune =
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
forall a.
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PDimension
d PWeight
w (TuningParameter -> ProposalSimple a
f TuningParameter
1.0) (Tuner a -> Maybe (Tuner a)
forall a. a -> Maybe a
Just Tuner a
tuner)
where
fT :: TuningParameter -> TuningParameter -> TuningParameter
fT = PDimension -> TuningParameter -> TuningParameter -> TuningParameter
defaultTuningFunction PDimension
d
fTs :: Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fTs = Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
forall a.
Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
noAuxiliaryTuningFunction
g :: TuningParameter
-> p -> Either a (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
g TuningParameter
t p
_ = (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
-> Either a (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
forall a b. b -> Either a b
Right ((a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
-> Either a (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian)))
-> (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
-> Either a (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
forall a b. (a -> b) -> a -> b
$ TuningParameter -> ProposalSimple a
f TuningParameter
t
tuner :: Tuner a
tuner = TuningParameter
-> (TuningParameter -> TuningParameter -> TuningParameter)
-> AuxiliaryTuningParameters
-> (Vector a
-> AuxiliaryTuningParameters -> AuxiliaryTuningParameters)
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a))
-> Tuner a
forall a.
TuningParameter
-> (TuningParameter -> TuningParameter -> TuningParameter)
-> AuxiliaryTuningParameters
-> (Vector a
-> AuxiliaryTuningParameters -> AuxiliaryTuningParameters)
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a))
-> Tuner a
Tuner TuningParameter
1.0 TuningParameter -> TuningParameter -> TuningParameter
fT AuxiliaryTuningParameters
forall a. Vector a
VB.empty Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
forall a.
Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fTs TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a)
forall p a.
TuningParameter
-> p -> Either a (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
g
createProposal PDescription
r TuningParameter -> ProposalSimple a
f PDimension
d PName
n PWeight
w Tune
NoTune =
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
forall a.
PName
-> PDescription
-> PDimension
-> PWeight
-> ProposalSimple a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PDimension
d PWeight
w (TuningParameter -> ProposalSimple a
f TuningParameter
1.0) Maybe (Tuner a)
forall a. Maybe a
Nothing
tuningParameterMin :: TuningParameter
tuningParameterMin :: TuningParameter
tuningParameterMin = TuningParameter
1e-5
tuningParameterMax :: TuningParameter
tuningParameterMax :: TuningParameter
tuningParameterMax = TuningParameter
1e3
tuneWithTuningParameters ::
TuningParameter ->
AuxiliaryTuningParameters ->
Proposal a ->
Either String (Proposal a)
tuneWithTuningParameters :: TuningParameter
-> AuxiliaryTuningParameters
-> Proposal a
-> Either String (Proposal a)
tuneWithTuningParameters TuningParameter
t AuxiliaryTuningParameters
ts Proposal a
p = case Proposal a -> Maybe (Tuner a)
forall a. Proposal a -> Maybe (Tuner a)
prTuner Proposal a
p of
Maybe (Tuner a)
Nothing -> String -> Either String (Proposal a)
forall a b. a -> Either a b
Left String
"tuneWithTuningParameters: Proposal is not tunable."
Just (Tuner TuningParameter
_ TuningParameter -> TuningParameter -> TuningParameter
fT AuxiliaryTuningParameters
_ Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fTs TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a)
g) ->
let t' :: TuningParameter
t' = TuningParameter -> TuningParameter -> TuningParameter
forall a. Ord a => a -> a -> a
max TuningParameter
tuningParameterMin TuningParameter
t
t'' :: TuningParameter
t'' = TuningParameter -> TuningParameter -> TuningParameter
forall a. Ord a => a -> a -> a
min TuningParameter
tuningParameterMax TuningParameter
t'
psE :: Either String (ProposalSimple a)
psE = TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a)
g TuningParameter
t'' AuxiliaryTuningParameters
ts
in case Either String (a -> Gen RealWorld -> IO (a, Jacobian, Jacobian))
psE of
Left String
err -> String -> Either String (Proposal a)
forall a b. a -> Either a b
Left (String -> Either String (Proposal a))
-> String -> Either String (Proposal a)
forall a b. (a -> b) -> a -> b
$ String
"tune: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err
Right a -> Gen RealWorld -> IO (a, Jacobian, Jacobian)
ps -> Proposal a -> Either String (Proposal a)
forall a b. b -> Either a b
Right (Proposal a -> Either String (Proposal a))
-> Proposal a -> Either String (Proposal a)
forall a b. (a -> b) -> a -> b
$ Proposal a
p {prSimple :: ProposalSimple a
prSimple = a -> Gen RealWorld -> IO (a, Jacobian, Jacobian)
ProposalSimple a
ps, prTuner :: Maybe (Tuner a)
prTuner = Tuner a -> Maybe (Tuner a)
forall a. a -> Maybe a
Just (Tuner a -> Maybe (Tuner a)) -> Tuner a -> Maybe (Tuner a)
forall a b. (a -> b) -> a -> b
$ TuningParameter
-> (TuningParameter -> TuningParameter -> TuningParameter)
-> AuxiliaryTuningParameters
-> (Vector a
-> AuxiliaryTuningParameters -> AuxiliaryTuningParameters)
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a))
-> Tuner a
forall a.
TuningParameter
-> (TuningParameter -> TuningParameter -> TuningParameter)
-> AuxiliaryTuningParameters
-> (Vector a
-> AuxiliaryTuningParameters -> AuxiliaryTuningParameters)
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a))
-> Tuner a
Tuner TuningParameter
t'' TuningParameter -> TuningParameter -> TuningParameter
fT AuxiliaryTuningParameters
ts Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fTs TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a)
g}
tuneWithChainParameters :: AcceptanceRate -> VB.Vector a -> Proposal a -> Either String (Proposal a)
tuneWithChainParameters :: TuningParameter
-> Vector a -> Proposal a -> Either String (Proposal a)
tuneWithChainParameters TuningParameter
ar Vector a
xs Proposal a
p = case Proposal a -> Maybe (Tuner a)
forall a. Proposal a -> Maybe (Tuner a)
prTuner Proposal a
p of
Maybe (Tuner a)
Nothing -> String -> Either String (Proposal a)
forall a b. a -> Either a b
Left String
"tuneWithChainParameters: Proposal is not tunable."
Just (Tuner TuningParameter
t TuningParameter -> TuningParameter -> TuningParameter
fT AuxiliaryTuningParameters
ts Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fTs TuningParameter
-> AuxiliaryTuningParameters -> Either String (ProposalSimple a)
_) ->
let t' :: TuningParameter
t' = TuningParameter -> TuningParameter -> TuningParameter
fT TuningParameter
ar TuningParameter
t
ts' :: AuxiliaryTuningParameters
ts' = Vector a -> AuxiliaryTuningParameters -> AuxiliaryTuningParameters
fTs Vector a
xs AuxiliaryTuningParameters
ts
in TuningParameter
-> AuxiliaryTuningParameters
-> Proposal a
-> Either String (Proposal a)
forall a.
TuningParameter
-> AuxiliaryTuningParameters
-> Proposal a
-> Either String (Proposal a)
tuneWithTuningParameters TuningParameter
t' AuxiliaryTuningParameters
ts' Proposal a
p
getOptimalRate :: PDimension -> Double
getOptimalRate :: PDimension -> TuningParameter
getOptimalRate (PDimension Int
n)
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> TuningParameter
forall a. HasCallStack => String -> a
error String
"getOptimalRate: Proposal dimension is zero or negative."
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = TuningParameter
0.44
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = TuningParameter
0.3885
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 = TuningParameter
0.337
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 = TuningParameter
0.2855
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
5 = TuningParameter
0.234
| Bool
otherwise = String -> TuningParameter
forall a. HasCallStack => String -> a
error String
"getOptimalRate: Proposal dimension is not an integer?"
getOptimalRate PDimension
PDimensionUnknown = TuningParameter
0.234
getOptimalRate (PSpecial Int
_ TuningParameter
r) = TuningParameter
r
rateMin :: Double
rateMin :: TuningParameter
rateMin = TuningParameter
0.1
rateMax :: Double
rateMax :: TuningParameter
rateMax = TuningParameter
0.9
renderRow ::
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString ->
BL.ByteString
renderRow :: ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
renderRow ByteString
name ByteString
ptype ByteString
weight ByteString
nAccept ByteString
nReject ByteString
acceptRate ByteString
optimalRate ByteString
tuneParam ByteString
manualAdjustment = ByteString
nm ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
wt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
na ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
nr ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ra ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ro ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tp ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
mt
where
nm :: ByteString
nm = Int -> ByteString -> ByteString
alignLeft Int
30 ByteString
name
pt :: ByteString
pt = Int -> ByteString -> ByteString
alignLeft Int
50 ByteString
ptype
wt :: ByteString
wt = Int -> ByteString -> ByteString
alignRight Int
8 ByteString
weight
na :: ByteString
na = Int -> ByteString -> ByteString
alignRight Int
14 ByteString
nAccept
nr :: ByteString
nr = Int -> ByteString -> ByteString
alignRight Int
14 ByteString
nReject
ra :: ByteString
ra = Int -> ByteString -> ByteString
alignRight Int
14 ByteString
acceptRate
ro :: ByteString
ro = Int -> ByteString -> ByteString
alignRight Int
14 ByteString
optimalRate
tp :: ByteString
tp = Int -> ByteString -> ByteString
alignRight Int
20 ByteString
tuneParam
mt :: ByteString
mt = Int -> ByteString -> ByteString
alignRight Int
30 ByteString
manualAdjustment
proposalHeader :: BL.ByteString
=
ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
renderRow
ByteString
"Name"
ByteString
"Description"
ByteString
"Weight"
ByteString
"Accepted"
ByteString
"Rejected"
ByteString
"Rate"
ByteString
"Optimal rate"
ByteString
"Tuning parameter"
ByteString
"Consider manual adjustment"
summarizeProposal ::
PName ->
PDescription ->
PWeight ->
Maybe TuningParameter ->
PDimension ->
Maybe (Int, Int, Double) ->
BL.ByteString
summarizeProposal :: PName
-> PDescription
-> PWeight
-> Maybe TuningParameter
-> PDimension
-> Maybe (Int, Int, TuningParameter)
-> ByteString
summarizeProposal PName
name PDescription
description PWeight
weight Maybe TuningParameter
tuningParameter PDimension
dimension Maybe (Int, Int, TuningParameter)
ar =
ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
renderRow
(String -> ByteString
BL.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ PName -> String
fromPName PName
name)
(String -> ByteString
BL.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ PDescription -> String
fromPDescription PDescription
description)
ByteString
weightStr
ByteString
nAccept
ByteString
nReject
ByteString
acceptRate
ByteString
optimalRate
ByteString
tuneParamStr
ByteString
manualAdjustmentStr
where
weightStr :: ByteString
weightStr = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Builder
BB.intDec (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ PWeight -> Int
fromPWeight PWeight
weight
nAccept :: ByteString
nAccept = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
-> ((Int, Int, TuningParameter) -> Builder)
-> Maybe (Int, Int, TuningParameter)
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (Int -> Builder
BB.intDec (Int -> Builder)
-> ((Int, Int, TuningParameter) -> Int)
-> (Int, Int, TuningParameter)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, TuningParameter)
-> Getting Int (Int, Int, TuningParameter) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Int, Int, TuningParameter) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1)) Maybe (Int, Int, TuningParameter)
ar
nReject :: ByteString
nReject = Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder
-> ((Int, Int, TuningParameter) -> Builder)
-> Maybe (Int, Int, TuningParameter)
-> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (Int -> Builder
BB.intDec (Int -> Builder)
-> ((Int, Int, TuningParameter) -> Int)
-> (Int, Int, TuningParameter)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, TuningParameter)
-> Getting Int (Int, Int, TuningParameter) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Int, Int, TuningParameter) Int
forall s t a b. Field2 s t a b => Lens s t a b
_2)) Maybe (Int, Int, TuningParameter)
ar
acceptRate :: ByteString
acceptRate = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> ((Int, Int, TuningParameter) -> ByteString)
-> Maybe (Int, Int, TuningParameter)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (Int -> TuningParameter -> ByteString
BC.toFixed Int
2 (TuningParameter -> ByteString)
-> ((Int, Int, TuningParameter) -> TuningParameter)
-> (Int, Int, TuningParameter)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, TuningParameter)
-> Getting
TuningParameter (Int, Int, TuningParameter) TuningParameter
-> TuningParameter
forall s a. s -> Getting a s a -> a
^. Getting TuningParameter (Int, Int, TuningParameter) TuningParameter
forall s t a b. Field3 s t a b => Lens s t a b
_3)) Maybe (Int, Int, TuningParameter)
ar
optimalRate :: ByteString
optimalRate = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> TuningParameter -> ByteString
BC.toFixed Int
2 (TuningParameter -> ByteString) -> TuningParameter -> ByteString
forall a b. (a -> b) -> a -> b
$ PDimension -> TuningParameter
getOptimalRate PDimension
dimension
tuneParamStr :: ByteString
tuneParamStr = ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> (TuningParameter -> ByteString)
-> Maybe TuningParameter
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (Int -> TuningParameter -> ByteString
BC.toFixed Int
4) Maybe TuningParameter
tuningParameter
checkRate :: TuningParameter -> Maybe a
checkRate TuningParameter
rate
| TuningParameter
rate TuningParameter -> TuningParameter -> Bool
forall a. Ord a => a -> a -> Bool
< TuningParameter
rateMin = a -> Maybe a
forall a. a -> Maybe a
Just a
"rate too low"
| TuningParameter
rate TuningParameter -> TuningParameter -> Bool
forall a. Ord a => a -> a -> Bool
> TuningParameter
rateMax = a -> Maybe a
forall a. a -> Maybe a
Just a
"rate too high"
| Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
checkTuningParam :: TuningParameter -> Maybe a
checkTuningParam TuningParameter
tp
| TuningParameter
tp TuningParameter -> TuningParameter -> Bool
forall a. Ord a => a -> a -> Bool
<= (TuningParameter
1.1 TuningParameter -> TuningParameter -> TuningParameter
forall a. Num a => a -> a -> a
* TuningParameter
tuningParameterMin) = a -> Maybe a
forall a. a -> Maybe a
Just a
"tuning parameter too low"
| TuningParameter
tp TuningParameter -> TuningParameter -> Bool
forall a. Ord a => a -> a -> Bool
>= (TuningParameter
0.9 TuningParameter -> TuningParameter -> TuningParameter
forall a. Num a => a -> a -> a
* TuningParameter
tuningParameterMax) = a -> Maybe a
forall a. a -> Maybe a
Just a
"tuning parameter too high"
| Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
tps :: Maybe ByteString
tps = TuningParameter -> Maybe ByteString
forall a. IsString a => TuningParameter -> Maybe a
checkTuningParam (TuningParameter -> Maybe ByteString)
-> Maybe TuningParameter -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe TuningParameter
tuningParameter
ars :: Maybe ByteString
ars = (TuningParameter -> Maybe ByteString
forall a. IsString a => TuningParameter -> Maybe a
checkRate (TuningParameter -> Maybe ByteString)
-> ((Int, Int, TuningParameter) -> TuningParameter)
-> (Int, Int, TuningParameter)
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, TuningParameter)
-> Getting
TuningParameter (Int, Int, TuningParameter) TuningParameter
-> TuningParameter
forall s a. s -> Getting a s a -> a
^. Getting TuningParameter (Int, Int, TuningParameter) TuningParameter
forall s t a b. Field3 s t a b => Lens s t a b
_3)) ((Int, Int, TuningParameter) -> Maybe ByteString)
-> Maybe (Int, Int, TuningParameter) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Int, Int, TuningParameter)
ar
manualAdjustmentStr :: ByteString
manualAdjustmentStr =
let
in case (Maybe ByteString
ars, Maybe ByteString
tps) of
(Maybe ByteString
Nothing, Maybe ByteString
Nothing) -> ByteString
""
(Just ByteString
s, Maybe ByteString
_) -> ByteString
s
(Maybe ByteString
_, Just ByteString
s) -> ByteString
s