{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Mcmc.Proposal
(
PName (..),
PDescription (..),
PWeight (fromPWeight),
pWeight,
PDimension (..),
PSpeed (..),
Proposal (..),
KernelRatio,
PResult (..),
Jacobian,
JacobianFunction,
PFunction,
createProposal,
Tuner (..),
Tune (..),
TuningParameter,
TuningType (..),
TuningFunction,
AuxiliaryTuningParameters,
tuningFunction,
tuningParameterMin,
tuningParameterMax,
tuneWithTuningParameters,
getOptimalRate,
(@~),
liftProposal,
liftProposalWith,
proposalHeader,
summarizeProposal,
)
where
import Data.Bifunctor
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Function
import qualified Data.Vector as VB
import qualified Data.Vector.Unboxed as VU
import Lens.Micro
import Mcmc.Acceptance
import Mcmc.Internal.ByteString
import Mcmc.Jacobian
import Numeric.Log hiding (sum)
import System.Random.Stateful
newtype PName = PName {PName -> [Char]
fromPName :: String}
deriving (Int -> PName -> ShowS
[PName] -> ShowS
PName -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PName] -> ShowS
$cshowList :: [PName] -> ShowS
show :: PName -> [Char]
$cshow :: PName -> [Char]
showsPrec :: Int -> PName -> ShowS
$cshowsPrec :: Int -> PName -> ShowS
Show, PName -> PName -> Bool
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
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
Ord)
deriving (Semigroup PName
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
Monoid, NonEmpty PName -> PName
PName -> PName -> 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 :: forall b. Integral b => 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 -> [Char]
fromPDescription :: String}
deriving (Int -> PDescription -> ShowS
[PDescription] -> ShowS
PDescription -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PDescription] -> ShowS
$cshowList :: [PDescription] -> ShowS
show :: PDescription -> [Char]
$cshow :: PDescription -> [Char]
showsPrec :: Int -> PDescription -> ShowS
$cshowsPrec :: Int -> PDescription -> ShowS
Show, PDescription -> PDescription -> Bool
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
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
Ord)
newtype PWeight = PWeight {PWeight -> Int
fromPWeight :: Int}
deriving (Int -> PWeight -> ShowS
[PWeight] -> ShowS
PWeight -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PWeight] -> ShowS
$cshowList :: [PWeight] -> ShowS
show :: PWeight -> [Char]
$cshow :: PWeight -> [Char]
showsPrec :: Int -> PWeight -> ShowS
$cshowsPrec :: Int -> PWeight -> ShowS
Show, PWeight -> PWeight -> Bool
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
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
Ord)
pWeight :: Int -> PWeight
pWeight :: Int -> PWeight
pWeight Int
n
| Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"pWeight: Proposal weight is zero or negative: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
n forall a. Semigroup a => a -> a -> a
<> [Char]
"."
| Bool
otherwise = Int -> PWeight
PWeight Int
n
data PDimension
= PDimension Int
| PDimensionUnknown
|
PSpecial Int Double
data PSpeed = PFast | PSlow
deriving (PSpeed -> PSpeed -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PSpeed -> PSpeed -> Bool
$c/= :: PSpeed -> PSpeed -> Bool
== :: PSpeed -> PSpeed -> Bool
$c== :: PSpeed -> PSpeed -> Bool
Eq)
data Proposal a = Proposal
{
forall a. Proposal a -> PName
prName :: PName,
forall a. Proposal a -> PDescription
prDescription :: PDescription,
forall a. Proposal a -> PSpeed
prSpeed :: PSpeed,
forall a. Proposal a -> PDimension
prDimension :: PDimension,
forall a. Proposal a -> PWeight
prWeight :: PWeight,
forall a. Proposal a -> PFunction a
prFunction :: PFunction a,
forall 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 = forall a. Proposal a -> PName
prName Proposal a
m forall a. Eq a => a -> a -> Bool
== forall a. Proposal a -> PName
prName Proposal a
n Bool -> Bool -> Bool
&& forall a. Proposal a -> PDescription
prDescription Proposal a
m forall a. Eq a => a -> a -> Bool
== forall a. Proposal a -> PDescription
prDescription Proposal a
n
instance Ord (Proposal a) where
compare :: Proposal a -> Proposal a -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (\Proposal a
p -> (forall a. Proposal a -> PDescription
prDescription Proposal a
p, forall a. Proposal a -> PName
prName Proposal a
p, forall a. Proposal a -> PWeight
prWeight Proposal a
p))
type KernelRatio = Log Double
data PResult a
=
ForceAccept !a
|
ForceReject
|
Propose !a !KernelRatio !Jacobian
deriving (Int -> PResult a -> ShowS
forall a. Show a => Int -> PResult a -> ShowS
forall a. Show a => [PResult a] -> ShowS
forall a. Show a => PResult a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PResult a] -> ShowS
$cshowList :: forall a. Show a => [PResult a] -> ShowS
show :: PResult a -> [Char]
$cshow :: forall a. Show a => PResult a -> [Char]
showsPrec :: Int -> PResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PResult a -> ShowS
Show, PResult a -> PResult a -> Bool
forall a. Eq a => PResult a -> PResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PResult a -> PResult a -> Bool
$c/= :: forall a. Eq a => PResult a -> PResult a -> Bool
== :: PResult a -> PResult a -> Bool
$c== :: forall a. Eq a => PResult a -> PResult a -> Bool
Eq)
type PFunction a = a -> IOGenM StdGen -> IO (PResult a, Maybe AcceptanceRates)
createProposal ::
PDescription ->
(TuningParameter -> PFunction a) ->
PSpeed ->
PDimension ->
PName ->
PWeight ->
Tune ->
Proposal a
createProposal :: forall a.
PDescription
-> (TuningParameter -> PFunction a)
-> PSpeed
-> PDimension
-> PName
-> PWeight
-> Tune
-> Proposal a
createProposal PDescription
r TuningParameter -> PFunction a
f PSpeed
s PDimension
d PName
n PWeight
w Tune
Tune =
forall a.
PName
-> PDescription
-> PSpeed
-> PDimension
-> PWeight
-> PFunction a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PSpeed
s PDimension
d PWeight
w (TuningParameter -> PFunction a
f TuningParameter
1.0) (forall a. a -> Maybe a
Just Tuner a
tuner)
where
fT :: TuningFunction a
fT = forall a. TuningFunction a
tuningFunction
g :: TuningParameter -> p -> Either a (PFunction a)
g TuningParameter
t p
_ = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ TuningParameter -> PFunction a
f TuningParameter
t
tuner :: Tuner a
tuner = forall a.
TuningParameter
-> AuxiliaryTuningParameters
-> Bool
-> Bool
-> TuningFunction a
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction a))
-> Tuner a
Tuner TuningParameter
1.0 forall a. Unbox a => Vector a
VU.empty Bool
False Bool
False forall a. TuningFunction a
fT forall {p} {a}. TuningParameter -> p -> Either a (PFunction a)
g
createProposal PDescription
r TuningParameter -> PFunction a
f PSpeed
s PDimension
d PName
n PWeight
w Tune
NoTune =
forall a.
PName
-> PDescription
-> PSpeed
-> PDimension
-> PWeight
-> PFunction a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PSpeed
s PDimension
d PWeight
w (TuningParameter -> PFunction a
f TuningParameter
1.0) forall a. Maybe a
Nothing
data Tuner a = Tuner
{ forall a. Tuner a -> TuningParameter
tTuningParameter :: TuningParameter,
forall a. Tuner a -> AuxiliaryTuningParameters
tAuxiliaryTuningParameters :: AuxiliaryTuningParameters,
forall a. Tuner a -> Bool
tRequireTrace :: Bool,
forall a. Tuner a -> Bool
tSuitableForIntermediateTuning :: Bool,
forall a. Tuner a -> TuningFunction a
tTuningFunction :: TuningFunction a,
forall a.
Tuner a
-> TuningParameter
-> AuxiliaryTuningParameters
-> Either [Char] (PFunction a)
tGetPFunction ::
TuningParameter ->
AuxiliaryTuningParameters ->
Either String (PFunction a)
}
data Tune = Tune | NoTune
deriving (Int -> Tune -> ShowS
[Tune] -> ShowS
Tune -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Tune] -> ShowS
$cshowList :: [Tune] -> ShowS
show :: Tune -> [Char]
$cshow :: Tune -> [Char]
showsPrec :: Int -> Tune -> ShowS
$cshowsPrec :: Int -> Tune -> ShowS
Show, Tune -> Tune -> Bool
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
data TuningType
=
NormalTuningFastProposalsOnly
|
IntermediateTuningFastProposalsOnly
|
LastTuningFastProposalsOnly
|
NormalTuningAllProposals
|
IntermediateTuningAllProposals
|
LastTuningAllProposals
deriving (TuningType -> TuningType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TuningType -> TuningType -> Bool
$c/= :: TuningType -> TuningType -> Bool
== :: TuningType -> TuningType -> Bool
$c== :: TuningType -> TuningType -> Bool
Eq)
type TuningFunction a =
TuningType ->
PDimension ->
Maybe AcceptanceRate ->
Maybe (VB.Vector a) ->
(TuningParameter, AuxiliaryTuningParameters) ->
(TuningParameter, AuxiliaryTuningParameters)
type AuxiliaryTuningParameters = VU.Vector TuningParameter
tuningFunctionSimple :: PDimension -> AcceptanceRate -> TuningParameter -> TuningParameter
tuningFunctionSimple :: PDimension -> TuningParameter -> TuningParameter -> TuningParameter
tuningFunctionSimple PDimension
d TuningParameter
r TuningParameter
t = let rO :: TuningParameter
rO = PDimension -> TuningParameter
getOptimalRate PDimension
d in forall a. Floating a => a -> a
exp (TuningParameter
2 forall a. Num a => a -> a -> a
* (TuningParameter
r forall a. Num a => a -> a -> a
- TuningParameter
rO)) forall a. Num a => a -> a -> a
* TuningParameter
t
tuningFunction :: TuningFunction a
tuningFunction :: forall a. TuningFunction a
tuningFunction TuningType
IntermediateTuningFastProposalsOnly PDimension
_ Maybe TuningParameter
_ Maybe (Vector a)
_ (TuningParameter, AuxiliaryTuningParameters)
t = (TuningParameter, AuxiliaryTuningParameters)
t
tuningFunction TuningType
IntermediateTuningAllProposals PDimension
_ Maybe TuningParameter
_ Maybe (Vector a)
_ (TuningParameter, AuxiliaryTuningParameters)
t = (TuningParameter, AuxiliaryTuningParameters)
t
tuningFunction TuningType
_ PDimension
_ Maybe TuningParameter
Nothing Maybe (Vector a)
_ (TuningParameter, AuxiliaryTuningParameters)
t = (TuningParameter, AuxiliaryTuningParameters)
t
tuningFunction TuningType
_ PDimension
d (Just TuningParameter
r) Maybe (Vector a)
_ (!TuningParameter
t, !AuxiliaryTuningParameters
ts) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PDimension -> TuningParameter -> TuningParameter -> TuningParameter
tuningFunctionSimple PDimension
d TuningParameter
r) (TuningParameter
t, AuxiliaryTuningParameters
ts)
tuningParameterMin :: TuningParameter
tuningParameterMin :: TuningParameter
tuningParameterMin = TuningParameter
1e-6
tuningParameterMax :: TuningParameter
tuningParameterMax :: TuningParameter
tuningParameterMax = TuningParameter
5e3
tuneWithTuningParameters ::
TuningParameter ->
AuxiliaryTuningParameters ->
Proposal a ->
Either String (Proposal a)
tuneWithTuningParameters :: forall a.
TuningParameter
-> AuxiliaryTuningParameters
-> Proposal a
-> Either [Char] (Proposal a)
tuneWithTuningParameters TuningParameter
t AuxiliaryTuningParameters
ts Proposal a
p = case forall a. Proposal a -> Maybe (Tuner a)
prTuner Proposal a
p of
Maybe (Tuner a)
Nothing -> forall a b. a -> Either a b
Left [Char]
"tuneWithTuningParameters: Proposal is not tunable."
Just (Tuner TuningParameter
_ AuxiliaryTuningParameters
_ Bool
reqTr Bool
inTn TuningFunction a
fT TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction a)
g) ->
let t' :: TuningParameter
t' = forall a. Ord a => a -> a -> a
max TuningParameter
tuningParameterMin TuningParameter
t
t'' :: TuningParameter
t'' = forall a. Ord a => a -> a -> a
min TuningParameter
tuningParameterMax TuningParameter
t'
psE :: Either [Char] (PFunction a)
psE = TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction a)
g TuningParameter
t'' AuxiliaryTuningParameters
ts
in case Either [Char] (PFunction a)
psE of
Left [Char]
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"tune: " forall a. Semigroup a => a -> a -> a
<> [Char]
err
Right PFunction a
ps -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Proposal a
p {prFunction :: PFunction a
prFunction = PFunction a
ps, prTuner :: Maybe (Tuner a)
prTuner = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a.
TuningParameter
-> AuxiliaryTuningParameters
-> Bool
-> Bool
-> TuningFunction a
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction a))
-> Tuner a
Tuner TuningParameter
t'' AuxiliaryTuningParameters
ts Bool
reqTr Bool
inTn TuningFunction a
fT TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction a)
g}
getOptimalRate :: PDimension -> Double
getOptimalRate :: PDimension -> TuningParameter
getOptimalRate (PDimension Int
n)
| Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"getOptimalRate: Proposal dimension is zero or negative."
| Int
n forall a. Eq a => a -> a -> Bool
== Int
1 = TuningParameter
0.44
| Int
n forall a. Eq a => a -> a -> Bool
== Int
2 = TuningParameter
0.3885
| Int
n forall a. Eq a => a -> a -> Bool
== Int
3 = TuningParameter
0.337
| Int
n forall a. Eq a => a -> a -> Bool
== Int
4 = TuningParameter
0.2855
| Int
n forall a. Ord a => a -> a -> Bool
>= Int
5 = TuningParameter
0.234
| Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"getOptimalRate: Proposal dimension is not an integer?"
getOptimalRate PDimension
PDimensionUnknown = TuningParameter
0.234
getOptimalRate (PSpecial Int
_ TuningParameter
r) = TuningParameter
r
infixl 7 @~
(@~) :: Lens' b a -> Proposal a -> Proposal b
@~ :: forall b a. 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 :: forall b a. Lens' b a -> Proposal a -> Proposal b
liftProposal = forall b a.
JacobianFunction b -> Lens' b a -> Proposal a -> Proposal b
liftProposalWith (forall a b. a -> b -> a
const KernelRatio
1.0)
liftProposalWith :: JacobianFunction b -> Lens' b a -> Proposal a -> Proposal b
liftProposalWith :: forall b a.
JacobianFunction b -> Lens' b a -> Proposal a -> Proposal b
liftProposalWith JacobianFunction b
jf Lens' b a
l (Proposal PName
n PDescription
r PSpeed
d PDimension
p PWeight
w PFunction a
s Maybe (Tuner a)
t) =
forall a.
PName
-> PDescription
-> PSpeed
-> PDimension
-> PWeight
-> PFunction a
-> Maybe (Tuner a)
-> Proposal a
Proposal PName
n PDescription
r PSpeed
d PDimension
p PWeight
w (forall b a.
JacobianFunction b -> Lens' b a -> PFunction a -> PFunction b
liftPFunctionWith JacobianFunction b
jf Lens' b a
l PFunction a
s) (forall b a. JacobianFunction b -> Lens' b a -> Tuner a -> Tuner b
liftTunerWith JacobianFunction b
jf Lens' b a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Tuner a)
t)
liftPFunctionWith :: JacobianFunction b -> Lens' b a -> PFunction a -> PFunction b
liftPFunctionWith :: forall b a.
JacobianFunction b -> Lens' b a -> PFunction a -> PFunction b
liftPFunctionWith JacobianFunction b
jf Lens' b a
l PFunction a
s = b -> IOGenM StdGen -> IO (PResult b, Maybe AcceptanceRates)
s'
where
s' :: b -> IOGenM StdGen -> IO (PResult b, Maybe AcceptanceRates)
s' b
y IOGenM StdGen
g = do
(PResult a
pr, Maybe AcceptanceRates
ac) <- PFunction a
s (b
y forall s a. s -> Getting a s a -> a
^. Lens' b a
l) IOGenM StdGen
g
let pr' :: PResult b
pr' = case PResult a
pr of
ForceAccept a
x' -> forall a. a -> PResult a
ForceAccept forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' b a
l a
x' b
y
PResult a
ForceReject -> forall a. PResult a
ForceReject
Propose a
x' KernelRatio
r KernelRatio
j ->
let y' :: b
y' = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' b a
l a
x' b
y
jxy :: KernelRatio
jxy = JacobianFunction b
jf b
y
jyx :: KernelRatio
jyx = JacobianFunction b
jf b
y'
j' :: KernelRatio
j' = KernelRatio
j forall a. Num a => a -> a -> a
* KernelRatio
jyx forall a. Fractional a => a -> a -> a
/ KernelRatio
jxy
in forall a. a -> KernelRatio -> KernelRatio -> PResult a
Propose b
y' KernelRatio
r KernelRatio
j'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PResult b
pr', Maybe AcceptanceRates
ac)
liftTunerWith :: JacobianFunction b -> Lens' b a -> Tuner a -> Tuner b
liftTunerWith :: forall b a. JacobianFunction b -> Lens' b a -> Tuner a -> Tuner b
liftTunerWith JacobianFunction b
jf Lens' b a
l (Tuner TuningParameter
p AuxiliaryTuningParameters
ps Bool
reqTr Bool
inTn TuningFunction a
fP TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction a)
g) = forall a.
TuningParameter
-> AuxiliaryTuningParameters
-> Bool
-> Bool
-> TuningFunction a
-> (TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction a))
-> Tuner a
Tuner TuningParameter
p AuxiliaryTuningParameters
ps Bool
reqTr Bool
inTn TuningType
-> PDimension
-> Maybe TuningParameter
-> Maybe (Vector b)
-> (TuningParameter, AuxiliaryTuningParameters)
-> (TuningParameter, AuxiliaryTuningParameters)
fP' TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction b)
g'
where
fP' :: TuningType
-> PDimension
-> Maybe TuningParameter
-> Maybe (Vector b)
-> (TuningParameter, AuxiliaryTuningParameters)
-> (TuningParameter, AuxiliaryTuningParameters)
fP' TuningType
b PDimension
d Maybe TuningParameter
r = TuningFunction a
fP TuningType
b PDimension
d Maybe TuningParameter
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> Vector a -> Vector b
VB.map (forall s a. s -> Getting a s a -> a
^. Lens' b a
l))
g' :: TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction b)
g' TuningParameter
x AuxiliaryTuningParameters
xs = forall b a.
JacobianFunction b -> Lens' b a -> PFunction a -> PFunction b
liftPFunctionWith JacobianFunction b
jf Lens' b a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TuningParameter
-> AuxiliaryTuningParameters -> Either [Char] (PFunction a)
g TuningParameter
x AuxiliaryTuningParameters
xs
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
acceptRateActual ByteString
optimalRate ByteString
tuneParam ByteString
manualAdjustment =
ByteString
nm forall a. Semigroup a => a -> a -> a
<> ByteString
pt forall a. Semigroup a => a -> a -> a
<> ByteString
wt forall a. Semigroup a => a -> a -> a
<> ByteString
na forall a. Semigroup a => a -> a -> a
<> ByteString
nr forall a. Semigroup a => a -> a -> a
<> ByteString
ra forall a. Semigroup a => a -> a -> a
<> ByteString
ro forall a. Semigroup a => a -> a -> a
<> ByteString
tp 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
acceptRateActual
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
"Actual rate"
ByteString
"Optimal rate"
ByteString
"Tuning parameter"
ByteString
"Consider manual adjustment"
summarizeProposal ::
PName ->
PDescription ->
PWeight ->
Maybe TuningParameter ->
PDimension ->
(Int, Int, Maybe Double, Maybe Double) ->
BL.ByteString
summarizeProposal :: PName
-> PDescription
-> PWeight
-> Maybe TuningParameter
-> PDimension
-> (Int, Int, Maybe TuningParameter, Maybe TuningParameter)
-> ByteString
summarizeProposal PName
name PDescription
description PWeight
weight Maybe TuningParameter
tuningParameter PDimension
dimension (Int, Int, Maybe TuningParameter, Maybe TuningParameter)
ar =
ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> ByteString
renderRow
([Char] -> ByteString
BL.pack forall a b. (a -> b) -> a -> b
$ PName -> [Char]
fromPName PName
name)
([Char] -> ByteString
BL.pack forall a b. (a -> b) -> a -> b
$ PDescription -> [Char]
fromPDescription PDescription
description)
ByteString
weightStr
ByteString
nAccept
ByteString
nReject
ByteString
acceptRateActual
ByteString
optimalRate
ByteString
tuneParamStr
ByteString
manualAdjustmentStr
where
fN :: Int -> TuningParameter -> Builder
fN Int
n = FloatFormat -> TuningParameter -> Builder
BB.formatDouble (Int -> FloatFormat
BB.standard Int
n)
weightStr :: ByteString
weightStr = Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Int -> Builder
BB.intDec forall a b. (a -> b) -> a -> b
$ PWeight -> Int
fromPWeight PWeight
weight
nAccept :: ByteString
nAccept = Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Int -> Builder
BB.intDec forall a b. (a -> b) -> a -> b
$ (Int, Int, Maybe TuningParameter, Maybe TuningParameter)
ar forall s a. s -> Getting a s a -> a
^. forall s t a b. Field1 s t a b => Lens s t a b
_1
nReject :: ByteString
nReject = Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Int -> Builder
BB.intDec forall a b. (a -> b) -> a -> b
$ (Int, Int, Maybe TuningParameter, Maybe TuningParameter)
ar forall s a. s -> Getting a s a -> a
^. forall s t a b. Field2 s t a b => Lens s t a b
_2
acceptRateActual :: ByteString
acceptRateActual = Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (Int -> TuningParameter -> Builder
fN Int
2) ((Int, Int, Maybe TuningParameter, Maybe TuningParameter)
ar forall s a. s -> Getting a s a -> a
^. forall s t a b. Field3 s t a b => Lens s t a b
_3)
optimalRate :: ByteString
optimalRate = Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ Int -> TuningParameter -> Builder
fN Int
2 forall a b. (a -> b) -> a -> b
$ PDimension -> TuningParameter
getOptimalRate PDimension
dimension
tuneParamStr :: ByteString
tuneParamStr = Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (Int -> TuningParameter -> Builder
fN Int
6) Maybe TuningParameter
tuningParameter
checkRate :: TuningParameter -> Maybe a
checkRate TuningParameter
rate
| TuningParameter
rate forall a. Ord a => a -> a -> Bool
< TuningParameter
rateMin = forall a. a -> Maybe a
Just a
"rate too low"
| TuningParameter
rate forall a. Ord a => a -> a -> Bool
> TuningParameter
rateMax = forall a. a -> Maybe a
Just a
"rate too high"
| Bool
otherwise = forall a. Maybe a
Nothing
checkTuningParam :: TuningParameter -> Maybe a
checkTuningParam TuningParameter
tp
| TuningParameter
tp forall a. Ord a => a -> a -> Bool
<= (TuningParameter
1.1 forall a. Num a => a -> a -> a
* TuningParameter
tuningParameterMin) = forall a. a -> Maybe a
Just a
"tuning parameter too low"
| TuningParameter
tp forall a. Ord a => a -> a -> Bool
>= (TuningParameter
0.9 forall a. Num a => a -> a -> a
* TuningParameter
tuningParameterMax) = forall a. a -> Maybe a
Just a
"tuning parameter too high"
| Bool
otherwise = forall a. Maybe a
Nothing
tps :: Maybe ByteString
tps = forall {a}. IsString a => TuningParameter -> Maybe a
checkTuningParam forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe TuningParameter
tuningParameter
ars :: Maybe ByteString
ars = forall {a}. IsString a => TuningParameter -> Maybe a
checkRate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Int, Int, Maybe TuningParameter, Maybe TuningParameter)
ar forall s a. s -> Getting a s a -> a
^. forall s t a b. Field3 s t a b => Lens s t a b
_3)
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