SciBaseTypes 0.1.0.0 → 0.1.1.0

raw patch · 8 files changed

+204/−25 lines, 8 filesdep +DPutilsdep ~log-domaindep ~semiringsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: DPutils

Dependency ranges changed: log-domain, semirings

API changes (from Hackage documentation)

Files

• Algebra/Structure/Semiring.hs +52/−6
• Numeric/Discretized.hs +26/−4
• Numeric/LogDomain.hs +66/−1
• README.md +2/−1
• SciBaseTypes.cabal +20/−4
• Statistics/Odds.hs +19/−7
• Statistics/Probability.hs +12/−2
• changelog.md +7/−0

@@ -9,6 +9,7 @@   ) where  import Control.DeepSeq (NFData(..))+import Data.Aeson import Data.Coerce import Data.Monoid hiding ((<>)) import Data.Semigroup@@ -19,6 +20,8 @@ import Numeric.Log import Unsafe.Coerce +import Data.Info+ import Numeric.Limits  @@ -37,8 +40,17 @@ (⊗) = times {-# Inline (⊗) #-} +-- | 'times' but done @n@ times.+--+-- TODO Include into type class to improve performance +nTimes :: Semiring a => Int -> a -> a+nTimes k  _ | k<=0 = one+nTimes 1  a = a+nTimes k !a = a ⊗ nTimes (k-1) a ++ -- * Newtype wrappers for 'SemiRing' that make the semiring to use explicit. -- This is important, because several types, say Prob(ability) have multiple -- useful semiring instances.@@ -50,7 +62,8 @@ -- | The Viterbi SemiRing. It maximizes over the product.  newtype Viterbi x = Viterbi { getViterbi ∷ x }-  deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)+  deriving stock (Eq, Ord, Read, Show, Bounded, Generic, Generic1)+  deriving newtype (Num)  derivingUnbox "Viterbi"   [t| forall x . Unbox x ⇒ Viterbi x → x |]  [| getViterbi |]  [| Viterbi |]@@ -59,6 +72,14 @@   rnf (Viterbi x) = rnf x   {-# Inline rnf #-} +instance (ToJSON x) ⇒ ToJSON (Viterbi x) where+  toJSON = toJSON . getViterbi++instance (FromJSON x) ⇒ FromJSON (Viterbi x) where+  parseJSON = fmap Viterbi . parseJSON+++ -- | -- -- TODO Shall we have generic instances, or specific ones like @SemiRing@@ -79,7 +100,8 @@ -- | The tropical MinPlus SemiRing. It minimizes over the sum.  newtype MinPlus x = MinPlus { getMinPlus ∷ x }-  deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)+  deriving stock (Eq, Ord, Read, Show, Bounded, Generic, Generic1)+  deriving newtype (Num)  derivingUnbox "MinPlus"   [t| forall x . Unbox x ⇒ MinPlus x → x |]  [| getMinPlus |]  [| MinPlus |]@@ -88,6 +110,12 @@   rnf (MinPlus x) = rnf x   {-# Inline rnf #-} +instance (ToJSON x) ⇒ ToJSON (MinPlus x) where+  toJSON = toJSON . getMinPlus++instance (FromJSON x) ⇒ FromJSON (MinPlus x) where+  parseJSON = fmap MinPlus . parseJSON+ instance NumericLimits x ⇒ NumericLimits (MinPlus x) where   minFinite = MinPlus minFinite   maxFinite = MinPlus maxFinite@@ -111,7 +139,8 @@ -- | The tropical MaxPlus SemiRing. It maximizes over the sum.  newtype MaxPlus x = MaxPlus { getMaxPlus ∷ x }-  deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)+  deriving stock (Eq, Ord, Read, Show, Bounded, Generic, Generic1)+  deriving newtype (Num)  derivingUnbox "MaxPlus"   [t| forall x . Unbox x ⇒ MaxPlus x → x |]  [| getMaxPlus |]  [| MaxPlus |]@@ -120,10 +149,19 @@   rnf (MaxPlus x) = rnf x   {-# Inline rnf #-} +instance (ToJSON x) ⇒ ToJSON (MaxPlus x) where+  toJSON = toJSON . getMaxPlus++instance (FromJSON x) ⇒ FromJSON (MaxPlus x) where+  parseJSON = fmap MaxPlus . parseJSON+ instance NumericLimits x ⇒ NumericLimits (MaxPlus x) where   minFinite = MaxPlus minFinite   maxFinite = MaxPlus maxFinite +instance Info x => Info (MaxPlus x) where+  info = info . getMaxPlus+ -- | -- -- TODO Shall we have generic instances, or specific ones like @SemiRing@@ -160,6 +198,16 @@ newtype GSemiring (zeroMonoid ∷ * → *) (oneMonoid ∷ * → *) (x ∷ *) = GSemiring { getSemiring ∷ x }   deriving (Eq, Ord, Read, Show, Generic) +instance NFData x ⇒ NFData (GSemiring zM oM x) where+  {-# Inline rnf #-}+  rnf (GSemiring x) = rnf x++instance (ToJSON x) ⇒ ToJSON (GSemiring z o x) where+  toJSON = toJSON . getSemiring++instance (FromJSON x) ⇒ FromJSON (GSemiring z o x) where+  parseJSON = fmap GSemiring . parseJSON+ instance   forall zeroMonoid oneMonoid x   . ( Semigroup (zeroMonoid x)@@ -190,7 +238,7 @@ -- * Semiring on 'Numeric.Log'. This is an orphan instance, but it can't be -- helped much, unless we want to wrap into yet another newtype. -instance (Precise a, RealFloat a) ⇒ Semiring (Log a) where+instance RealFloat a => Semiring (Log a) where   plus  = (+)   times = (*)   zero  = 0@@ -199,6 +247,4 @@   {-# Inline times #-}   {-# Inline zero  #-}   {-# Inline one   #-}-- 

@@ -6,8 +6,9 @@  import Control.Applicative import Control.DeepSeq (NFData(..))-import Data.Aeson (FromJSON,ToJSON)+import Data.Aeson (FromJSON(..),ToJSON(..)) import Data.Binary (Binary)+import Data.Coerce import Data.Hashable (Hashable) import Data.Proxy import Data.Ratio@@ -18,6 +19,8 @@ import GHC.Real (Ratio(..)) import GHC.TypeLits +import Data.Info+ import Algebra.Structure.Semiring import Numeric.Limits @@ -36,6 +39,10 @@ class RatioTyConstant a where   ratioTyConstant ∷ Proxy a → Ratio Integer +instance (KnownNat k, KnownNat l) ⇒ RatioTyConstant (k :% l) where+  {-# Inline ratioTyConstant #-}+  ratioTyConstant Proxy = let k = natVal @k Proxy; l = natVal @l Proxy in  k :% l+ instance (KnownNat k) ⇒ RatioTyConstant (RTyExp (k∷Nat)) where   {-# Inline ratioTyConstant #-}   ratioTyConstant Proxy = let n = natVal @k Proxy in toRational (exp $ fromInteger n)@@ -81,8 +88,19 @@ -- Discretized values, which probably just works.  newtype Discretized (b ∷ k) = Discretized { getDiscretized ∷ Int }-  deriving (Eq,Ord,Generic,Show,Read)+  deriving (Eq,Ord,Generic,Read) +instance Show (Discretized b) where+  show (Discretized d) = show d++instance Info (Discretized b) where+  -- TODO show @b@ information+  info = show . getDiscretized++fromUnknown ∷ Discretized Unknown → Discretized t+{-# Inline fromUnknown #-}+fromUnknown = coerce+ derivingUnbox "Discretized"   [t| forall t . Discretized t → Int |]  [| getDiscretized |]  [| Discretized |] @@ -92,9 +110,13 @@  instance Binary    (Discretized t) instance Serialize (Discretized t)-instance FromJSON  (Discretized t)-instance ToJSON    (Discretized t) instance Hashable  (Discretized t)++instance (KnownNat k, KnownNat l) ⇒ ToJSON (Discretized (k :% l)) where+  toJSON = toJSON . fromRational @Double . toRational++instance (KnownNat k, KnownNat l) ⇒ FromJSON (Discretized (k :% l)) where+  parseJSON = fmap (fromRational . toRational @Double) . parseJSON  instance Num (Discretized Unknown) where   Discretized x + Discretized y = Discretized $ x+y

@@ -7,7 +7,11 @@ module Numeric.LogDomain where  import Control.Monad.Except-import Numeric.Log+import Numeric.Log as NL+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Fusion.Util as SM+import Debug.Trace+import Numeric   @@ -37,4 +41,65 @@   unsafelogdom = Exp . log   {-# Inline lindom #-}   lindom = exp . ln++++-- | This is similar to 'Numeric.Log.sum' but requires only one pass over the+-- data. It will be useful if the first two elements in the stream are large.+-- If the user has some control over how the stream is generated, this function+-- might show better performance than 'Numeric.Log.sum' and better numeric+-- stability than 'fold 0 (+)'+--+-- TODO this needs to be benchmarked against @fold 0 (+)@, since in+-- @DnaProteinAlignment@ @sumS@ seems to be slower!++sumS+  ∷ (Monad m, Ord a, RealFloat a, Show a)+  ⇒ Log a → SM.Stream m (Log a)+  → m (Log a)+{-# Inline sumS #-}+sumS zero (SM.Stream step s0) = sLoop1 SM.SPEC zero s0+  where+    -- we need to find the first @x@ that is not @(-1/0)@ to handle @x-m@+    -- correctly. We loop @sLoop1@ until we have the first finite @y@ and use+    -- that as the @m@ for @sLoop2@.+    sLoop1 SM.SPEC (Exp x) s = step s >>= \case+      SM.Done       → return $ Exp x+      SM.Skip    s1 → sLoop1 SM.SPEC (Exp x) s1+      SM.Yield (Exp y) s2+        | isInfinite y → sLoop1 SM.SPEC (Exp $ max x y) s2  -- either (1/0) or (-1/0) are handled correctly+        | otherwise    → sLoop2 SM.SPEC m (1∷Int) (expm1 (x-m) + expm1 (y-m)) s2+        where m = max x y+    -- from here on we are fine+    sLoop2 SM.SPEC m cnt acc s = step s >>= \case+      SM.Done       → return $ Exp $ m + log1p (acc + fromIntegral cnt)+      SM.Skip    s2 → sLoop2 SM.SPEC m cnt acc s2+      SM.Yield (Exp x) s2 → sLoop2 SM.SPEC m (cnt+1) (acc + expm1 (x-m)) s2++-- | @log-sum-exp@ for streams, without incurring examining the stream twice,+-- but with the potential for numeric problems. In pricinple, the numeric error+-- of this function should be better than individual binary function+-- application and worse than an optimized @sum@ function.+--+-- Needs to be written in direct style, as otherwise any constructors (to tell+-- us if we collected two elements already) remain.++logsumexpS+  ∷ (Monad m, Ord a, Num a, Floating a)+  ⇒ SM.Stream m a → m a+{-# Inline logsumexpS #-}+logsumexpS (SM.Stream step s0) = lseLoop0 SM.SPEC s0+  where+    lseLoop0 SM.SPEC s = step s >>= \case+      SM.Done        → return 0+      SM.Skip    s0' → lseLoop0 SM.SPEC s0'+      SM.Yield x s1  → lseLoop1 SM.SPEC x s1+    lseLoop1 SM.SPEC x s = step s >>= \case+      SM.Done        → return x+      SM.Skip    s1' → lseLoop1 SM.SPEC x s1'+      SM.Yield y sA  → let !m = max x y in lseLoopAcc SM.SPEC m (exp (x-m) + exp (y-m)) sA+    lseLoopAcc SM.SPEC !m !acc s = step s >>= \case+      SM.Done        → return $ m + log acc+      SM.Skip    sA' → lseLoopAcc SM.SPEC m acc sA'+      SM.Yield z sA' → lseLoopAcc SM.SPEC m (acc + exp (z-m)) sA' 

@@ -1,4 +1,5 @@-[![Build Status](https://travis-ci.org/choener/SciBaseTypes.svg?branch=master)](https://travis-ci.org/choener/SciBaseTypes)+![github action: master](https://github.com/choener/SciBaseTypes/actions/workflows/ci.yml/badge.svg)+![github action: master](https://github.com/choener/SciBaseTypes/actions/workflows/hackage.yml/badge.svg)  # SciBaseTypes 

@@ -1,17 +1,17 @@ Cabal-version:  2.2 Name:           SciBaseTypes-Version:        0.1.0.0+Version:        0.1.1.0 License:        BSD-3-Clause License-file:   LICENSE Author:         Christian Hoener zu Siederdissen Maintainer:     choener@bioinf.uni-leipzig.de-Copyright:      Christian Hoener zu Siederdissen, 2018-2019+Copyright:      Christian Hoener zu Siederdissen, 2018-2021 homepage:       https://github.com/choener/SciBaseTypes bug-reports:    https://github.com/choener/SciBaseTypes/issues Stability:      Experimental Category:       Data Build-type:     Simple-tested-with:    GHC == 8.4.4+tested-with:    GHC == 8.8, GHC == 8.10, GHC == 9.0 Synopsis:       Base types and classes for statistics, sciences and humanities Description:                 This library provides a set of basic types and classes for@@ -25,6 +25,13 @@   +flag debugdump+  description:  Enable dumping intermediate / core files+  default:      False+  manual:       True+++ common deps   build-depends: base                     >= 4.7      &&  < 5.0                , aeson                    >= 1.0@@ -35,9 +42,11 @@                , lens                     >= 4.0                , log-domain               >= 0.12                , mtl                      >= 2.0-               , semirings                >= 0.3+               , semirings                >= 0.5                , vector                   >= 0.10                , vector-th-unbox          >= 0.2+               --+               , DPutils                  == 0.1.1.*   default-language:     Haskell2010   ghc-options:@@ -47,9 +56,11 @@                     , ConstraintKinds                     , DataKinds                     , DeriveGeneric+                    , DerivingStrategies                     , FlexibleContexts                     , FlexibleInstances                     , GeneralizedNewtypeDeriving+                    , LambdaCase                     , MultiParamTypeClasses                     , PolyKinds                     , RankNTypes@@ -75,6 +86,11 @@     StatisticalMechanics.Ensemble     Statistics.Odds     Statistics.Probability+  if flag(debugdump)+    ghc-options:+      -ddump-to-file+      -ddump-simpl+      -dsuppress-all   

@@ -7,13 +7,15 @@ module Statistics.Odds where  import Control.DeepSeq (NFData(..))-import Data.Aeson (FromJSON,ToJSON)+import Data.Aeson (FromJSON(..),ToJSON(..)) import Data.Binary (Binary) import Data.Hashable (Hashable) import Data.Serialize (Serialize) import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic) +import Data.Info+ import Algebra.Structure.Semiring import Numeric.Discretized import Numeric.Limits@@ -25,10 +27,12 @@ newtype Odds = Odds { getOdds ∷ Double }   deriving (Generic,Eq,Ord,Show,Read,Num) -deriving instance Semiring Odds+instance NFData Odds +deriving newtype instance Semiring Odds  + -- | Encodes log-odds that have been rounded or clamped to integral numbers. -- One advantage this provides is more efficient "maximum/minimum" calculations -- compared to using @Double@s.@@ -40,19 +44,24 @@ newtype DiscLogOdds (t∷k) = DiscLogOdds { getDiscLogOdds ∷ Discretized t }   deriving (Generic,Eq,Ord,Show,Read) -deriving instance (Num (Discretized (t∷k))) ⇒ Num (DiscLogOdds t)--deriving instance (Semiring (Discretized (t∷k))) ⇒ Semiring (DiscLogOdds t)+deriving newtype instance (Num (Discretized (t∷k))) ⇒ Num (DiscLogOdds t)+deriving newtype instance (Semiring (Discretized (t∷k))) ⇒ Semiring (DiscLogOdds t)+deriving newtype instance (Fractional (Discretized (t∷k))) ⇒ Fractional (DiscLogOdds t)+deriving newtype instance (Real (Discretized (t∷k))) ⇒ Real (DiscLogOdds (t::k))  derivingUnbox "DiscretizedLogOdds"   [t| forall t . DiscLogOdds t → Int |]  [| getDiscretized . getDiscLogOdds |]  [| DiscLogOdds . Discretized |]  instance Binary    (DiscLogOdds t) instance Serialize (DiscLogOdds t)-instance FromJSON  (DiscLogOdds t)-instance ToJSON    (DiscLogOdds t) instance Hashable  (DiscLogOdds t) +instance ToJSON (Discretized t) ⇒ ToJSON (DiscLogOdds t) where+  toJSON = toJSON . getDiscLogOdds++instance FromJSON (Discretized t) ⇒ FromJSON  (DiscLogOdds t) where+  parseJSON = fmap DiscLogOdds . parseJSON+ instance (NFData (Discretized t)) ⇒ NFData (DiscLogOdds t) where   rnf (DiscLogOdds k) = rnf k   {-# Inline rnf #-}@@ -62,4 +71,7 @@   {-# Inline minFinite #-}   maxFinite = DiscLogOdds maxFinite   {-# Inline maxFinite #-}++instance Info (DiscLogOdds t) where+  info = info . getDiscLogOdds 

@@ -6,10 +6,13 @@  module Statistics.Probability where +import Control.DeepSeq import Control.Lens+import Data.Aeson import Data.Char (chr) import Data.Vector.Unboxed.Deriving import Data.Vector.Unboxed (Unbox)+import GHC.Generics(Generic) import Numeric.Log  import Algebra.Structure.Semiring@@ -29,8 +32,10 @@ -- they are in the range @[0,...,∞]@.  newtype Probability (n ∷ IsNormalized) x = Prob { getProb ∷ x }-  deriving (Eq,Ord,Show,Read)+  deriving (Eq,Ord,Show,Read,Generic) +instance (NFData x) ⇒ NFData (Probability n x)+ derivingUnbox "Probability"   [t| forall n x. Unbox x ⇒ Probability n x → x |]  [| getProb |]  [| Prob |] @@ -41,7 +46,12 @@ deriving instance (Real       x) ⇒ Real       (Probability n x) deriving instance (RealFrac   x) ⇒ RealFrac   (Probability n x) deriving instance (RealFloat  x) ⇒ RealFloat  (Probability n x)-deriving instance (Precise    x) ⇒ Precise    (Probability n x)++instance ToJSON x ⇒ ToJSON (Probability n x) where+  toJSON = toJSON . getProb++instance FromJSON x ⇒ FromJSON (Probability n x) where+  parseJSON = fmap Prob . parseJSON  instance (Num r) ⇒ Semiring (Probability n r) where   plus  = (+)

@@ -1,3 +1,10 @@+0.1.1.0+-------++- missing instances+- knowDiscretized -> fromUnknown+- updated DPutils dependency (Data.Info)+ 0.1.0.0 ------- - depending on @semirings@ now, instead of our own type class. breaks existing