packages feed

numhask-space 0.7.0.0 → 0.7.1.0

raw patch · 9 files changed

+111/−74 lines, 9 filesdep +randomdep +vector

Dependencies added: random, vector

Files

numhask-space.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: numhask-space-version: 0.7.0.0+version: 0.7.1.0 synopsis:   Numerical spaces. description:@@ -51,6 +51,8 @@     -Wincomplete-record-updates     -Wincomplete-uni-patterns     -Wredundant-constraints+    -fwrite-ide-info+    -hiedir=.hie   default-extensions:   build-depends:     adjunctions >=4.0 && <5,@@ -58,10 +60,12 @@     containers >= 0.6 && < 0.7,     distributive >=0.2.2 && <1,     numhask >= 0.7 && < 0.8,+    random >=1.2 && < 1.3,     semigroupoids >=5 && <6,     tdigest >= 0.2.1 && < 0.3,     text >= 1.2.3.1 && <2,     time >= 1.9.1 && <1.12,+    vector >= 0.12 && < 0.13,   exposed-modules:     NumHask.Space     NumHask.Space.Types@@ -90,4 +94,6 @@     -Wincomplete-record-updates     -Wincomplete-uni-patterns     -Wredundant-constraints+    -fwrite-ide-info+    -hiedir=.hie   default-extensions:
src/NumHask/Space.hs view
@@ -3,8 +3,19 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} --- | Mathematics does not rigorously define a [space](https://en.wikipedia.org/wiki/Space_(mathematics\)), leaving library devs free to push boundaries on what a space is.--- +-- | Mathematics does not rigorously define a [space](https://en.wikipedia.org/wiki/Space_(mathematics\)), leaving library devs free to explore.+--+-- “But who can quantify+--  the algebra of space,+--  or weigh those worlds that swim+--  each in its place?+--  Who can outdo the dark?+--  And what computer knows+--  how beauty comes to birth -+--  shell star and rose?+--+-- ~ Technicians by Jean Kenward”+-- ~ John Foster module NumHask.Space   ( -- * Usage     -- $setup
src/NumHask/Space/Histogram.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}  -- | A histogram, if you squint, is a series of contiguous 'Range's, annotated with values. module NumHask.Space.Histogram@@ -12,7 +14,6 @@     makeRects,     regularQuantiles,     quantileFold,-    fromQuantiles,     freq,     average,     quantiles,@@ -20,9 +21,9 @@   ) where -import qualified Data.List as List import qualified Data.Map as Map import qualified Data.TDigest as TD+import qualified Data.Vector as V import NumHask.Prelude import NumHask.Space.Range import NumHask.Space.Rect@@ -31,8 +32,9 @@ -- | This Histogram is a list of contiguous boundaries (a boundary being the lower edge of one bucket and the upper edge of another), and a value (usually a count) for each bucket, represented here as a map -- -- Overs and Unders are contained in key = 0 and key = length cuts+-- Intervals are defined as (l,u] data Histogram = Histogram-  { cuts :: [Double], -- bucket boundaries+  { cuts :: V.Vector Double, -- bucket boundaries     values :: Map.Map Int Double -- bucket counts   }   deriving (Show, Eq)@@ -42,22 +44,37 @@  -- | Fill a Histogram using pre-specified cuts ----- >>> fill [0,50,100] [1..100]+-- >>> fill [0,50,100] [0..99] -- Histogram {cuts = [0.0,50.0,100.0], values = fromList [(1,50.0),(2,50.0)]} fill :: (Foldable f) => [Double] -> f Double -> Histogram-fill cs xs = Histogram cs (foldl' (\x a -> Map.insertWith (+) (cutI cs a) 1 x) Map.empty xs)+fill cs xs =+  Histogram+    (V.fromList cs)+    (foldl' (\x a -> Map.insertWith (+) (cutI (V.fromList cs) a) 1 x) Map.empty xs)  -- | find the index of the bucket the value is contained in.-cutI :: (Ord a) => [a] -> a -> Int-cutI bs n = go bs 0+cutI :: (Ord a) => V.Vector a -> a -> Int+cutI cs a = go (Range zero (V.length cs))   where-    go [] i = i-    go (x : xs) i = bool i (go xs (i + 1)) (n > x)+    go (Range l u) =+      let k = (u + l) `div` 2+       in case compare a (cs V.! k) of+            EQ -> k + 1+            LT -> bool (go (Range l k)) k (l == k)+            GT ->+              bool+                ( case compare a (cs V.! (k + one)) of+                    EQ -> k + 2+                    LT -> k + 1+                    GT -> go (Range k u)+                )+                (k + 1)+                (k >= u - one)  -- | Make a histogram using n equally spaced cuts over the entire range of the data -- -- >>> regular 4 [0..100]--- Histogram {cuts = [0.0,25.0,50.0,75.0,100.0], values = fromList [(0,1.0),(1,25.0),(2,25.0),(3,25.0),(4,25.0)]}+-- Histogram {cuts = [0.0,25.0,50.0,75.0,100.0], values = fromList [(1,25.0),(2,25.0),(3,25.0),(4,25.0),(5,1.0)]} regular :: Int -> [Double] -> Histogram regular n xs = fill cs xs   where@@ -68,28 +85,27 @@ -- >>> makeRects IgnoreOvers (regular 4 [0..100]) -- [Rect 0.0 25.0 0.0 0.25,Rect 25.0 50.0 0.0 0.25,Rect 50.0 75.0 0.0 0.25,Rect 75.0 100.0 0.0 0.25] makeRects :: DealOvers -> Histogram -> [Rect Double]-makeRects o (Histogram cs counts) = List.zipWith4 Rect x z y w'+makeRects o (Histogram cs counts) = V.toList $ V.zipWith3 (\x z w' -> Rect x z zero w') x z w'   where-    y = repeat 0     w =-      zipWith+      V.zipWith         (/)-        ((\x' -> Map.findWithDefault 0 x' counts) <$> [f .. l])-        (zipWith (-) z x)+        ((\x' -> Map.findWithDefault 0 x' counts) <$> V.enumFromN f (l - f + one))+        (V.zipWith (-) z x)     f = case o of-      IgnoreOvers -> 1-      IncludeOvers _ -> 0+      IgnoreOvers -> one+      IncludeOvers _ -> zero     l = case o of-      IgnoreOvers -> length cs - 1+      IgnoreOvers -> length cs - one       IncludeOvers _ -> length cs     w' = (/ sum w) <$> w     x = case o of       IgnoreOvers -> cs       IncludeOvers outw ->-        [List.head cs - outw]+        V.singleton (V.head cs - outw)           <> cs-          <> [List.last cs + outw]-    z = drop 1 x+          <> V.singleton (V.last cs + outw)+    z = V.drop one x  -- | approx regular n-quantiles --@@ -108,23 +124,11 @@     begin = TD.tdigest ([] :: [Double]) :: TD.TDigest 25     done x = fromMaybe (0 / 0) . (`TD.quantile` TD.compress x) <$> qs --- | take a specification of quantiles and make a Histogram------ >>> fromQuantiles [0,0.25,0.5,0.75,1] (regularQuantiles 4 [0..100])--- Histogram {cuts = [0.0,24.75,50.0,75.25,100.0], values = fromList [(1,0.25),(2,0.25),(3,0.25),(4,0.25)]}-fromQuantiles :: [Double] -> [Double] -> Histogram-fromQuantiles qs xs = Histogram xs (Map.fromList $ zip [1 ..] (diffq qs))-  where-    diffq [] = []-    diffq [_] = []-    diffq (x : xs') = (reverse . snd) $ foldl' step (x, []) xs'-    step (a0, xs') a = (a, (a - a0) : xs')- -- | normalize a histogram -- -- > \h -> sum (values $ freq h) == one ----- >>> freq $ fill [0,50,100] [1..100]+-- >>> freq $ fill [0,50,100] [0..99] -- Histogram {cuts = [0.0,50.0,100.0], values = fromList [(1,0.5),(2,0.5)]} freq :: Histogram -> Histogram freq (Histogram cs vs) = Histogram cs $ Map.map (* recip (sum vs)) vs@@ -140,7 +144,6 @@ -- -- >>> quantiles 5 [1..1000] -- [1.0,200.5,400.5,600.5000000000001,800.5,1000.0]--- quantiles :: (Foldable f) => Int -> f Double -> [Double] quantiles n xs =   ( \x ->@@ -153,6 +156,5 @@ -- -- >>> quantile 0.1 [1..1000] -- 100.5--- quantile :: (Foldable f) => Double -> f Double -> Double quantile p xs = fromMaybe 0 $ TD.quantile p (TD.tdigest xs :: TD.TDigest 25)
src/NumHask/Space/Point.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} @@ -173,7 +174,7 @@   norm (Point x y) = sqrt (x * x + y * y)   basis p = p /. norm p --- | angle formed by a vector from trhe origin to a Point and the x-axis (Point 1 0). Note that an angle between two points p1 & p2 is thus angle p2 - angle p1+-- | angle formed by a vector from the origin to a Point and the x-axis (Point 1 0). Note that an angle between two points p1 & p2 is thus angle p2 - angle p1 -- -- > \u@(Point ux uy) v@(Point vx vy) -> angle v - angle u == sign (ux*vy-uy*vx) * acos (dotP u v / (norm u * norm v)) instance (TrigField a) => Direction (Point a) a where@@ -286,4 +287,3 @@     det = crossP d1 d2     a = crossP p1 p2     b = crossP p3 p4-
src/NumHask/Space/Range.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-}
src/NumHask/Space/Rect.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-}
src/NumHask/Space/Time.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}@@ -24,11 +25,13 @@   ) where +import Data.Containers.ListUtils (nubOrd) import Data.Fixed (Fixed (MkFixed))-import Data.List (nub)+import qualified Data.Sequence as Seq import Data.String (String) import Data.Time import NumHask.Prelude+import NumHask.Space.Range import NumHask.Space.Types  -- $setup@@ -70,7 +73,9 @@  -- | convenience conversion to Double fromNominalDiffTime :: NominalDiffTime -> Double-fromNominalDiffTime t = let (MkFixed i) = nominalDiffTimeToSeconds t in fromInteger i * 1e-12+fromNominalDiffTime t = fromInteger i * 1e-12+  where+    (MkFixed i) = nominalDiffTimeToSeconds t  -- | convenience conversion from Double toNominalDiffTime :: Double -> NominalDiffTime@@ -87,14 +92,13 @@ -- >>> fromDiffTime $ toDiffTime 1 -- 1.0 fromDiffTime :: DiffTime -> Double-fromDiffTime =-  (/ 1e12) . fromIntegral . fromEnum+fromDiffTime = (* 1e-12) . fromInteger . diffTimeToPicoseconds  -- | Convert from seconds (as a Double) to 'DiffTime' -- >>> toDiffTime 1 -- 1s toDiffTime :: Double -> DiffTime-toDiffTime d = toEnum . fromEnum $ d * 1e12+toDiffTime = picosecondsToDiffTime . floor . (* 1e12)  -- | add a TimeGrain to a UTCTime --@@ -237,19 +241,18 @@ placedTimeLabelDiscontinuous :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> ([(Int, Text)], [UTCTime]) placedTimeLabelDiscontinuous posd format n ts = (zip (fst <$> inds') labels, rem')   where-    l = minimum ts-    u = maximum ts-    (grain, tps) = sensibleTimeGrid InnerPos n (l, u)+    r@(Range l u) = space1 ts+    (grain, tps) = sensibleTimeGrid InnerPos n r     tps' = case posd of       PosInnerOnly -> tps       PosIncludeBoundaries -> [l] <> tps <> [u]-    begin = (tps', [], 0)-    done (p, x, _) = (p, reverse x)+    begin = (tps', Seq.empty, zero :: Int)+    done (p, x, _) = (p, toList x)     step ([], xs, n) _ = ([], xs, n)     step (p : ps, xs, n) a-      | p == a = step (ps, (n, p) : xs, n) a+      | p == a = step (ps, xs Seq.:|> (n, p), n) a       | p > a = (p : ps, xs, n + 1)-      | otherwise = step (ps, (n - 1, p) : xs, n) a+      | otherwise = step (ps, xs Seq.:|> (n - 1, p), n) a     (rem', inds) = done $ foldl' step begin ts     inds' = laterTimes inds     fmt = case format of@@ -272,60 +275,72 @@ laterTimes :: [(Int, a)] -> [(Int, a)] laterTimes [] = [] laterTimes [x] = [x]-laterTimes (x : xs) = (\(x0, x1) -> reverse $ x0 : x1) $ foldl' step (x, []) xs+laterTimes (x : xs) =+  (\(x, xs) -> toList $ xs Seq.:|> x) $+    foldl' step (x, Seq.empty) xs   where-    step ((n, a), rs) (na, aa) = if na == n then ((na, aa), rs) else ((na, aa), (n, a) : rs)+    step ((n, a), rs) (na, aa) =+      bool ((na, aa), rs Seq.:|> (n, a)) ((na, aa), rs) (na == n)  -- | A sensible time grid between two dates, projected onto (0,1) with no attempt to get finnicky. ----- >>> placedTimeLabelContinuous PosIncludeBoundaries (Just "%d %b") 2 (UTCTime (fromGregorian 2017 12 6) (toDiffTime 0), UTCTime (fromGregorian 2017 12 29) (toDiffTime 0))+-- >>> placedTimeLabelContinuous PosIncludeBoundaries (Just "%d %b") 2 (Range (UTCTime (fromGregorian 2017 12 6) (toDiffTime 0)) (UTCTime (fromGregorian 2017 12 29) (toDiffTime 0))) -- [(0.0,"06 Dec"),(0.4347826086956521,"16 Dec"),(0.8695652173913042,"26 Dec"),(0.9999999999999999,"29 Dec")]-placedTimeLabelContinuous :: PosDiscontinuous -> Maybe Text -> Int -> (UTCTime, UTCTime) -> [(Double, Text)]-placedTimeLabelContinuous posd format n (l, u) = zip tpsd labels+placedTimeLabelContinuous :: PosDiscontinuous -> Maybe Text -> Int -> Range UTCTime -> [(Double, Text)]+placedTimeLabelContinuous posd format n r@(Range l u) = zip tpsd labels   where-    (grain, tps) = sensibleTimeGrid InnerPos n (l, u)+    (grain, tps) = sensibleTimeGrid InnerPos n r     tps' = case posd of       PosInnerOnly -> tps-      PosIncludeBoundaries -> nub $ [l] <> tps <> [u]+      PosIncludeBoundaries -> nubOrd $ [l] <> tps <> [u]     fmt = case format of       Just f -> unpack f       Nothing -> autoFormat grain     labels = pack . formatTime defaultTimeLocale fmt <$> tps'-    l' = minimum tps'-    u' = maximum tps'+    (Range l' u') = space1 tps'     r' = fromNominalDiffTime $ diffUTCTime u' l'     tpsd = (/ r') . fromNominalDiffTime . flip diffUTCTime l <$> tps'  -- | compute a sensible TimeGrain and list of UTCTimes ----- >>> sensibleTimeGrid InnerPos 2 (UTCTime (fromGregorian 2016 12 31) (toDiffTime 0), UTCTime (fromGregorian 2017 12 31) (toDiffTime 0))+-- >>> sensibleTimeGrid InnerPos 2 (Range (UTCTime (fromGregorian 2016 12 31) (toDiffTime 0)) (UTCTime (fromGregorian 2017 12 31) (toDiffTime 0))) -- (Months 6,[2016-12-31 00:00:00 UTC,2017-06-30 00:00:00 UTC,2017-12-31 00:00:00 UTC]) ----- >>> sensibleTimeGrid InnerPos 2 (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0), UTCTime (fromGregorian 2017 12 30) (toDiffTime 0))+-- >>> sensibleTimeGrid InnerPos 2 (Range (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0)) (UTCTime (fromGregorian 2017 12 30) (toDiffTime 0))) -- (Months 6,[2017-06-30 00:00:00 UTC]) ----- >>>  sensibleTimeGrid UpperPos 2 (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0), UTCTime (fromGregorian 2017 12 30) (toDiffTime 0))+-- >>>  sensibleTimeGrid UpperPos 2 (Range (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0)) (UTCTime (fromGregorian 2017 12 30) (toDiffTime 0))) -- (Months 6,[2017-06-30 00:00:00 UTC,2017-12-31 00:00:00 UTC]) ----- >>>sensibleTimeGrid LowerPos 2 (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0), UTCTime (fromGregorian 2017 12 30) (toDiffTime 0))+-- >>>sensibleTimeGrid LowerPos 2 (Range (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0)) (UTCTime (fromGregorian 2017 12 30) (toDiffTime 0))) -- (Months 6,[2016-12-31 00:00:00 UTC,2017-06-30 00:00:00 UTC])-sensibleTimeGrid :: Pos -> Int -> (UTCTime, UTCTime) -> (TimeGrain, [UTCTime])-sensibleTimeGrid p n (l, u) = (grain, ts)+sensibleTimeGrid :: Pos -> Int -> Range UTCTime -> (TimeGrain, [UTCTime])+sensibleTimeGrid p n (Range l u) = (grain, ts)   where     span' = u `diffUTCTime` l     grain = stepSensibleTime p span' n     first' = floorGrain grain l     last' = ceilingGrain grain u-    n' = round $ fromNominalDiffTime (diffUTCTime last' first') / grainSecs grain :: Integer+    n' =+      round $+        fromNominalDiffTime (diffUTCTime last' first')+          / grainSecs grain ::+        Integer     posns = case p of       OuterPos -> take (fromIntegral $ n' + 1)-      InnerPos -> drop (if first' == l then 0 else 1) . take (fromIntegral $ n' + if last' == u then 1 else 0)+      InnerPos ->+        drop (bool one zero (first' == l))+          . take (fromIntegral $ n' + bool zero one (last' == u))       UpperPos -> drop 1 . take (fromIntegral $ n' + 1)       LowerPos -> take (fromIntegral n')       MidPos -> take (fromIntegral n')     ts = case p of-      MidPos -> take (fromIntegral n') $ addHalfGrain grain . (\x -> addGrain grain x first') <$> [0 ..]-      _ -> posns $ (\x -> addGrain grain x first') <$> [0 ..]+      MidPos ->+        take (fromIntegral n') $+          addHalfGrain grain+            . (\x -> addGrain grain x first')+            <$> [0 ..]+      _notMid -> posns $ (\x -> addGrain grain x first') <$> [0 ..]  -- come up with a sensible step for a grid over a Field stepSensible ::
src/NumHask/Space/Types.hs view
@@ -335,6 +335,6 @@       (d' * b + e' * e)       (d' * c + e' * f + f') --- | Rotate an 'Affinity'+-- | Rotate an 'Affinity' (counter-clockwise) rotate :: (TrigField a) => a -> Transform a rotate a = Transform (cos a) (- sin a) zero (sin a) (cos a) zero
src/NumHask/Space/XY.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE StrictData #-}  -- | Unification of 'Point' and 'Rect'. module NumHask.Space.XY