Merge pull request #1936 from input-output-hk/jc/adjust-prior-for-poo…

…l-ranking

adjust prior distribution and percentile for pool ranking

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs

@@ -89,6 +89,9 @@ module Shelley.Spec.Ledger.LedgerState
     updateNES,
     circulation,
 
+    -- * Decay
+    decayFactor,
+
     -- * Remove Bootstrap Redeem Addresses
     returnRedeemAddrsToReserves,
   )
@@ -186,8 +189,9 @@ import Shelley.Spec.Ledger.PParams
     emptyPParams,
   )
 import Shelley.Spec.Ledger.Rewards
-  ( Likelihood,
+  ( Likelihood (..),
     NonMyopic (..),
+    applyDecay,
     emptyNonMyopic,
     reward,
   )
@@ -1038,6 +1042,9 @@ applyRUpd ru (EpochState as ss ls pr pp _nm) = EpochState as' ss ls' pr pp nm'
         }
     nm' = nonMyopic ru
 
+decayFactor :: Float
+decayFactor = 0.9
+
 updateNonMypopic ::
   NonMyopic era ->
   Coin ->
@@ -1050,7 +1057,11 @@ updateNonMypopic nm rPot newLikelihoods =
     }
   where
     history = likelihoodsNM nm
-    performance kh newPerf = fromMaybe mempty (Map.lookup kh history) <> newPerf
+    performance kh newPerf =
+      fromMaybe
+        mempty
+        (applyDecay decayFactor <$> Map.lookup kh history)
+        <> newPerf
     updatedLikelihoods = Map.mapWithKey performance newLikelihoods
 
 -- | Create a reward update

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Rewards.hs

@@ -19,6 +19,7 @@ module Shelley.Spec.Ledger.Rewards
     Histogram (..),
     LogWeight (..),
     likelihood,
+    applyDecay,
     Likelihood (..),
     leaderProbability,
   )
@@ -168,13 +169,17 @@ likelihood blocks t slotsPerEpoch =
     l x = n * log x + m * log (1 - t * x)
     sample position = LogWeight (realToFrac $ l position)
 
+-- | Decay previous likelihood
+applyDecay :: Float -> Likelihood -> Likelihood
+applyDecay decay (Likelihood logWeights) = Likelihood $ mul decay <$> logWeights
+  where
+    mul x (LogWeight f) = LogWeight (x * f)
+
 posteriorDistribution :: Histogram -> Likelihood -> Histogram
 posteriorDistribution (Histogram points) (Likelihood likelihoods) =
   normalize $
     Histogram $ Seq.zipWith (+) points likelihoods
 
--- TODO decay the histogram
-
 -- | Normalize the histogram so that the total area is 1
 normalize :: Histogram -> Histogram
 normalize (Histogram values) = Histogram $ (\x -> x - logArea) <$> values'
@@ -196,9 +201,9 @@ percentile p prior likelihoods =
     cdf = Seq.zip samplePositions $ Seq.scanl (+) 0 (fromLogWeight <$> values)
 
 percentile' :: Likelihood -> PerformanceEstimate
-percentile' = percentile 0.1 h
+percentile' = percentile 0.5 h
   where
-    h = normalize . Histogram $ logBeta 40 3 <$> samplePositions
+    h = normalize . Histogram $ logBeta 40 1 <$> samplePositions
     -- Beta(n,m)(x) = C * x^(n-1)*(1-x)^(m-1)
     -- log( Beta(n,m)(x) ) = (n-1) * log x + (m-1) * log (1-x)
     logBeta n m x = LogWeight . realToFrac $ (n -1) * log x + (m -1) * log (1 - x)

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/PoolLifetime.hs

@@ -48,12 +48,14 @@ import qualified Shelley.Spec.Ledger.EpochBoundary as EB
 import Shelley.Spec.Ledger.Keys (asWitness, coerceKeyRole)
 import Shelley.Spec.Ledger.LedgerState
   ( RewardUpdate (..),
+    decayFactor,
     emptyRewardUpdate,
   )
 import Shelley.Spec.Ledger.OCert (KESPeriod (..))
 import Shelley.Spec.Ledger.PParams (PParams' (..))
 import Shelley.Spec.Ledger.Rewards
-  ( Likelihood (..),
+  ( applyDecay,
+    Likelihood (..),
     NonMyopic (..),
     emptyNonMyopic,
     leaderProbability,
@@ -885,7 +887,7 @@ reserves12 :: Coin
 reserves12 = addDelta reserves7 deltaR8
 
 alicePerfEx11 :: forall era. ShelleyTest era => Likelihood
-alicePerfEx11 = alicePerfEx8 <> epoch4Likelihood
+alicePerfEx11 = applyDecay decayFactor alicePerfEx8 <> epoch4Likelihood
   where
     epoch4Likelihood = likelihood blocks t (epochSize $ EpochNo 4)
     blocks = 0