hyperloglog 0.3.4 → 0.4.0.1
raw patch · 7 files changed
+105/−193 lines, 7 filesdep +HerbiePlugin
Dependencies added: HerbiePlugin
Files
- .travis.yml +0/−1
- CHANGELOG.markdown +4/−0
- README.markdown +1/−1
- hyperloglog.cabal +11/−2
- src/Data/HyperLogLog.hs +4/−7
- src/Data/HyperLogLog/Config.hs +33/−148
- src/Data/HyperLogLog/Type.hs +52/−34
.travis.yml view
@@ -39,7 +39,6 @@ # this builds all libraries and executables # (including tests/benchmarks) - $CABAL build- - $CABAL test # tests that a source-distribution can be generated - $CABAL sdist
CHANGELOG.markdown view
@@ -1,3 +1,7 @@+0.4.0.1+-------+* Added `vector` 0.11 support.+ 0.3.4 ----- * Support `generic-deriving` 1.8. We no longer incur a `generic-deriving` requirement at all except on GHC < 7.6.
README.markdown view
@@ -1,7 +1,7 @@ hyperloglog =========== -[](http://travis-ci.org/ekmett/hyperloglog)+[](https://hackage.haskell.org/package/hyperloglog) [](http://travis-ci.org/ekmett/hyperloglog) This package provides a working implementation of HyperLogLog.
hyperloglog.cabal view
@@ -1,6 +1,6 @@ name: hyperloglog category: Numeric-version: 0.3.4+version: 0.4.0.1 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE@@ -42,6 +42,10 @@ default: True manual: True +flag herbie+ default: False+ manual: True+ library build-depends: approximate >= 0.2.1 && < 1,@@ -63,7 +67,12 @@ safecopy >= 0.8.1 && < 0.9, siphash >= 1.0.3 && < 2, tagged >= 0.4.5 && < 1,- vector >= 0.9 && < 0.11+ vector >= 0.9 && < 0.12++ if flag(herbie)+ build-depends: HerbiePlugin >= 0.1 && < 0.2+ cpp-options: -DHERBIE+ ghc-options: -fplugin=Herbie if impl(ghc < 7.6) build-depends: generic-deriving >= 1.4 && < 1.9
src/Data/HyperLogLog.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2013-2015@@ -19,13 +20,9 @@ , insert , insertHash , cast- -- * Config- , Config- , hll- -- * ReifiesConfig- , ReifiesConfig- , reifyConfig+#if __GLASGOW_HASKELL__ >= 708+ , coerceConfig+#endif ) where -import Data.HyperLogLog.Config import Data.HyperLogLog.Type
src/Data/HyperLogLog/Config.hs view
@@ -1,34 +1,15 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-cse #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-float-in #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 705+#if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-}-#define USE_TYPE_LITS 1 #endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-#define USE_NEW_TYPE_LITS 1-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 705 && __GLASGOW_HASKELL__ < 707-#define USE_OLD_TYPE_LITS 1-#endif--{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2013-2015@@ -41,12 +22,12 @@ module Data.HyperLogLog.Config ( -- * Config- Config- , HasConfig(..)- , hll- -- * ReifiesConfig- , ReifiesConfig(..)- , reifyConfig+ numBuckets+ , smallRange+ , interRange+ , rawFact+ , alpha+ , bucketMask -- * Rank , Rank , calcBucket@@ -54,27 +35,14 @@ , lim32 ) where -import Control.Lens import Data.Binary import Data.Bits import Data.Bits.Extras-import Data.Bytes.Serial-import Data.Proxy-import Data.Reflection-import Data.Serialize import Data.Vector.Serialize () import GHC.Int #if __GLASGOW_HASKELL__ < 710 import GHC.Word #endif-#if __GLASGOW_HASKELL__ < 706-import Generics.Deriving hiding (to, D)-#else-import GHC.Generics hiding (to, D)-#endif-#ifdef USE_TYPE_LITS-import GHC.TypeLits-#endif type Rank = Int8 @@ -82,125 +50,42 @@ -- Config ------------------------------------------------------------------------------ --- | Constants required for a bucketing factor b-data Config = Config- { _numBits :: {-# UNPACK #-} !Int- , _numBuckets :: {-# UNPACK #-} !Int- , _smallRange :: {-# UNPACK #-} !Double- , _interRange :: {-# UNPACK #-} !Double- , _rawFact :: {-# UNPACK #-} !Double- , _alpha :: {-# UNPACK #-} !Double- , _bucketMask :: {-# UNPACK #-} !Word32- } deriving (Eq, Show, Generic)--class HasConfig t where- config :: Getter t Config-- numBits :: Getter t Int- numBits = config . to _numBits-- numBuckets :: Getter t Int- numBuckets = config . to _numBuckets-- smallRange :: Getter t Double- smallRange = config . to _smallRange-- interRange :: Getter t Double- interRange = config . to _interRange-- rawFact :: Getter t Double- rawFact = config . to _rawFact-- alpha :: Getter t Double- alpha = config . to _alpha-- bucketMask :: Getter t Word32- bucketMask = config . to _bucketMask--instance HasConfig Config where- config = id- {-# INLINE config #-}--instance Serialize Config -- serialize as a number?--instance Binary Config where- put = serialize- get = deserialize--instance Serial Config---- | Precalculate constants for a given bucketing factor b-hll :: Int -> Config-hll b = Config- { _numBits = b- , _numBuckets = m- , _smallRange = 5/2 * m'- , _interRange = lim32 / 30- , _rawFact = a * m' * m'- , _alpha = a- , _bucketMask = bit b - 1- } where- m = bit b- m' = fromIntegral m- a = 0.7213 / (1 + 1.079 / m')-{-# INLINE hll #-}----------------------------------------------------------------------------------- ReifiesConfig---------------------------------------------------------------------------------class ReifiesConfig o where- reflectConfig :: p o -> Config--#ifdef USE_NEW_TYPE_LITS-instance KnownNat n => ReifiesConfig (n :: Nat) where- reflectConfig _ = hll $ fromInteger $ natVal (Proxy :: Proxy n)- {-# INLINE reflectConfig #-}-#endif--#ifdef USE_OLD_TYPE_LITS-instance SingRep n Integer => ReifiesConfig (n :: Nat) where- reflectConfig _ = hll $ fromInteger $ withSing $ \(x :: Sing n) -> fromSing x- {-# INLINE reflectConfig #-}-#endif--data ReifiedConfig (s :: *)+lim32 :: Double+lim32 = fromInteger (bit 32)+{-# INLINE lim32 #-} -retagReifiedConfig :: (Proxy s -> a) -> proxy (ReifiedConfig s) -> a-retagReifiedConfig f _ = f Proxy-{-# INLINE retagReifiedConfig #-}+numBuckets :: Integer -> Int+numBuckets b = unsafeShiftL 1 (fromIntegral b)+{-# INLINE numBuckets #-} -instance Reifies s Config => ReifiesConfig (ReifiedConfig s) where- reflectConfig = retagReifiedConfig reflect- {-# INLINE reflectConfig #-}+smallRange :: Integer -> Double+smallRange b = 5/2 * fromIntegral (numBuckets b)+{-# INLINE smallRange #-} -reifyConfig :: Int -> (forall (o :: *). ReifiesConfig o => Proxy o -> r) -> r-reifyConfig i f = reify (hll i) (go f) where- go :: (Proxy (ReifiedConfig o) -> a) -> proxy o -> a- go g _ = g Proxy-{-# INLINE reifyConfig #-}+interRange :: Double+interRange = lim32 / 30+{-# INLINE interRange #-} -instance Reifies n Int => ReifiesConfig (D n) where- reflectConfig = hll . reflect- {-# INLINE reflectConfig #-}+rawFact :: Integer -> Double+rawFact b = alpha b * m * m where+ m = fromIntegral (numBuckets b)+{-# INLINE rawFact #-} --- this way we only get instances for positive natural numbers-instance Reifies n Int => ReifiesConfig (SD n) where- reflectConfig = hll . reflect- {-# INLINE reflectConfig #-}+alpha :: Integer -> Double+alpha b = 0.7213 / (1 + 1.079 / fromIntegral (numBuckets b))+{-# INLINE alpha #-} +bucketMask :: Integer -> Word32+bucketMask b = fromIntegral (numBuckets b) - 1+ ------------------------------------------------------------------------------ -- Util ------------------------------------------------------------------------------ -calcBucket :: HasConfig t => t -> Word32 -> Int-calcBucket t w = fromIntegral (w .&. t^.bucketMask)+calcBucket :: Integer -> Word32 -> Int+calcBucket t w = fromIntegral (w .&. bucketMask t) {-# INLINE calcBucket #-} -calcRank :: HasConfig t => t -> Word32 -> Int8-calcRank t w = fromIntegral $ rank $ shiftR w $ t^.numBits+calcRank :: Integer -> Word32 -> Int8+calcRank t w = fromIntegral $ rank $ shiftR w $ fromIntegral t {-# INLINE calcRank #-}--lim32 :: Double-lim32 = fromInteger (bit 32)-{-# INLINE lim32 #-}
src/Data/HyperLogLog/Type.hs view
@@ -5,21 +5,20 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MonoLocalBinds #-} {-# OPTIONS_GHC -fno-cse #-} {-# OPTIONS_GHC -fno-full-laziness #-} {-# OPTIONS_GHC -fno-float-in #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}+#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-} #endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} #endif @@ -47,6 +46,9 @@ , insertHash , intersectionSize , cast+#if __GLASGOW_HASKELL__ >= 708+ , coerceConfig+#endif ) where #if __GLASGOW_HASKELL__ < 710@@ -57,7 +59,6 @@ import Control.Monad import Crypto.MAC.SipHash import Data.Approximate.Type-import Data.Bits import Data.Bits.Extras import qualified Data.Binary as Binary import Data.Binary@@ -65,6 +66,7 @@ import Data.Bytes.Serial import Data.HyperLogLog.Config import Data.Proxy+import Data.Reflection import Data.Semigroup import Data.Serialize as Serialize import qualified Data.Vector.Unboxed as V@@ -78,6 +80,9 @@ import GHC.Generics hiding (D, to) #endif import GHC.Int+#if __GLASGOW_HASKELL__ >= 708+import Data.Type.Coercion (Coercion(..))+#endif -- $setup -- >>> :set -XTemplateHaskell@@ -95,16 +100,16 @@ -- -- Initialize a new counter: ----- >>> mempty :: HyperLogLog $(3)+-- >>> mempty :: HyperLogLog 3 -- HyperLogLog {runHyperLogLog = fromList [0,0,0,0,0,0,0,0]} ----- Please note how you specify a counter size with the @$(n)@+-- Please note how you specify a counter size with the @n@ -- invocation. Sizes of up to 16 are valid, with 7 being a -- likely good minimum for decent accuracy. -- -- Let's count a list of unique items and get the latest estimate: ----- >>> size (foldr insert mempty [1..10] :: HyperLogLog $(4))+-- >>> size (foldr insert mempty [1..10] :: HyperLogLog 4) -- Approximate {_confidence = 0.9972, _lo = 2, _estimate = 9, _hi = 17} -- -- Note how 'insert' can be used to add new observations to the@@ -112,7 +117,16 @@ newtype HyperLogLog p = HyperLogLog { runHyperLogLog :: V.Vector Rank } deriving (Eq, Show, Generic) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+#if __GLASGOW_HASKELL__ >= 708+-- | If two types @p@ and @q@ reify the same configuration, then we can coerce+-- between @'HyperLogLog' p@ and @'HyperLogLog' q@. We do this by building+-- a hole in the @nominal@ role for the configuration parameter.+coerceConfig :: forall p q . (Reifies p Integer, Reifies q Integer) => Maybe (Coercion (HyperLogLog p) (HyperLogLog q))+coerceConfig | reflect (Proxy :: Proxy p) == reflect (Proxy :: Proxy q) = Just Coercion+ | otherwise = Nothing+#endif++#if __GLASGOW_HASKELL__ >= 707 type role HyperLogLog nominal #endif @@ -132,22 +146,19 @@ instance HasHyperLogLog (HyperLogLog p) p where hyperLogLog = id +-- TODO: prism to ensure the sizes are right _HyperLogLog :: Iso' (HyperLogLog p) (V.Vector Rank) _HyperLogLog = iso runHyperLogLog HyperLogLog {-# INLINE _HyperLogLog #-} -instance ReifiesConfig p => HasConfig (HyperLogLog p) where- config = to reflectConfig- {-# INLINE config #-}- instance Semigroup (HyperLogLog p) where HyperLogLog a <> HyperLogLog b = HyperLogLog (V.zipWith max a b) {-# INLINE (<>) #-} -- The 'Monoid' instance \"should\" just work. Give me two estimators and I -- can give you an estimator for the union set of the two.-instance ReifiesConfig p => Monoid (HyperLogLog p) where- mempty = HyperLogLog $ V.replicate (reflectConfig (Proxy :: Proxy p) ^. numBuckets) 0+instance Reifies p Integer => Monoid (HyperLogLog p) where+ mempty = HyperLogLog $ V.replicate (numBuckets (reflect (Proxy :: Proxy p))) 0 {-# INLINE mempty #-} mappend = (<>) {-# INLINE mappend #-}@@ -161,45 +172,53 @@ (SipHash !h) = hash sipKey bs {-# INLINE siphash #-} -insert :: (ReifiesConfig s, Serial a) => a -> HyperLogLog s -> HyperLogLog s+insert :: (Reifies s Integer, Serial a) => a -> HyperLogLog s -> HyperLogLog s insert = insertHash . w32 . siphash {-# INLINE insert #-} -- | Insert a value that has already been hashed by whatever user defined hash function you want.-insertHash :: ReifiesConfig s => Word32 -> HyperLogLog s -> HyperLogLog s+insertHash :: Reifies s Integer => Word32 -> HyperLogLog s -> HyperLogLog s insertHash h m@(HyperLogLog v) = HyperLogLog $ V.modify (\x -> do old <- MV.read x bk when (rnk > old) $ MV.write x bk rnk ) v where- !bk = calcBucket m h- !rnk = calcRank m h+ !n = reflect m+ !bk = calcBucket n h+ !rnk = calcRank n h {-# INLINE insertHash #-} -- | Approximate size of our set-size :: ReifiesConfig p => HyperLogLog p -> Approximate Int64+size :: Reifies p Integer => HyperLogLog p -> Approximate Int64 size m@(HyperLogLog bs) = Approximate 0.9972 l expected h where- m' = fromIntegral (m^.numBuckets)+ n = reflect m+ m' = fromIntegral (numBuckets n) numZeros = fromIntegral . V.length . V.filter (== 0) $ bs- res = case raw < m^.smallRange of- True | numZeros > 0 -> m' * log (m' / numZeros)+ res = case raw < smallRange n of+ True -- | numZeros > 0 -> m' * log (m' / numZeros) -- 13.47 bits max error+ | numZeros > 0 -> m' / 1 / (log m' - log numZeros) -- 6.47 bits max error | otherwise -> raw- False | raw <= m^.interRange -> raw- | otherwise -> -1 * lim32 * log (1 - raw / lim32)- raw = m^.rawFact * (1 / sm)+ False | raw <= interRange -> raw+ -- | otherwise -> -1 * lim32 * log (1 - raw / lim32) -- 44 bits max error+ | raw / lim32 < -1.7563532969399233e-6 -> - log (1 - (raw / lim32)) * lim32 -- 5.39 bits max error+ | otherwise -> raw + (raw / lim32) * raw++ raw = rawFact n * (1 / sm) sm = V.sum $ V.map (\x -> 1 / (2 ^^ x)) bs expected = round res- sd = err (m^.numBits)- err n = 1.04 / sqrt (fromInteger (bit n))+ sd = 1.04 / sqrt m' l = floor $ max (res*(1-3*sd)) 0 h = ceiling $ res*(1+3*sd) {-# INLINE size #-}+#ifdef HERBIE+{-# ANN size "NoHerbie" #-}+#endif -intersectionSize :: ReifiesConfig p => [HyperLogLog p] -> Approximate Int64+intersectionSize :: Reifies p Integer => [HyperLogLog p] -> Approximate Int64 intersectionSize [] = 0 intersectionSize (x:xs) = withMin 0 $ size x + intersectionSize xs - intersectionSize (mappend x <$> xs) {-# INLINE intersectionSize #-} -cast :: forall p q. (ReifiesConfig p, ReifiesConfig q) => HyperLogLog p -> Maybe (HyperLogLog q)+cast :: forall p q. (Reifies p Integer, Reifies q Integer) => HyperLogLog p -> Maybe (HyperLogLog q) cast old | newBuckets <= oldBuckets = Just $ over _HyperLogLog ?? mempty $ V.modify $ \m -> V.forM_ (V.indexed $ old^._HyperLogLog) $ \ (i,o) -> do@@ -208,7 +227,6 @@ MV.write m j (max o a) | otherwise = Nothing -- TODO? where- newConfig = reflectConfig (Proxy :: Proxy q)- newBuckets = newConfig^.numBuckets- oldBuckets = old^.numBuckets+ newBuckets = numBuckets (reflect (Proxy :: Proxy q))+ oldBuckets = numBuckets (reflect old) {-# INLINE cast #-}