src/Data/Gargantext/Prelude.hs

   1 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
   2 {-# OPTIONS_GHC -fno-warn-type-defaults  #-}
   3 {-# LANGUAGE     NoImplicitPrelude       #-}
   4
   5 {-
   6 TODO: import head impossible from Protolude: why ?
   7 -}
   8
   9 module Data.Gargantext.Prelude where
  10
  11 import Protolude ( Bool(True, False), Int, Double, Integer
  12                  , Fractional, Num, Maybe, Floating, Char
  13                  , Ord, Integral, Foldable, RealFrac, Monad, filter
  14                  , reverse, map, zip, drop, take, zipWith
  15                  , sum, fromIntegral, length, fmap
  16                  , takeWhile, sqrt, undefined, identity
  17                  , abs, maximum, minimum, return, snd, truncate
  18                  , (+), (*), (/), (-), (.), (>=), ($), (**), (^)
  19                  )
  20
  21 -- TODO import functions optimized in Utils.Count
  22 -- import Protolude hiding (head, last, all, any, sum, product, length)
  23 -- import Data.Gargantext.Utils.Count
  24
  25 import qualified Data.List     as L hiding (head, sum)
  26 import qualified Control.Monad as M
  27 import qualified Data.Map as Map
  28 import qualified Data.Vector as V
  29 -- import Safe (headMay)
  30
  31
  32 pf :: (a -> Bool) -> [a] -> [a]
  33 pf = filter
  34
  35 pr :: [a] -> [a]
  36 pr = reverse
  37
  38 pm :: (a -> b) -> [a] -> [b]
  39 pm = map
  40
  41 pm2 :: (t -> b) -> [[t]] -> [[b]]
  42 pm2 fun = pm (pm fun)
  43
  44 pz :: [a] -> [b] -> [(a, b)]
  45 pz  = zip
  46
  47 pd :: Int -> [a] -> [a]
  48 pd  = drop
  49
  50 ptk :: Int -> [a] -> [a]
  51 ptk = take
  52
  53 pzw :: (a -> b -> c) -> [a] -> [b] -> [c]
  54 pzw = zipWith
  55
  56 -- Exponential Average
  57 eavg :: [Double] -> Double
  58 eavg (x:xs) = a*x + (1-a)*(eavg xs)
  59   where a = 0.70
  60 eavg [] = 0
  61
  62 -- Simple Average
  63 mean :: Fractional a => [a] -> a
  64 mean xs = if L.null xs then 0.0
  65                        else sum xs / fromIntegral (length xs)
  66
  67 sumMaybe :: Num a => [Maybe a] -> Maybe a
  68 sumMaybe = fmap sum . M.sequence
  69
  70 variance :: Floating a => [a] -> a
  71 variance xs = mean $ pm (\x -> (x - m) ** 2) xs where
  72     m = mean xs
  73
  74 deviation :: [Double] -> Double
  75 deviation = sqrt . variance
  76
  77 movingAverage :: Fractional b => Int -> [b] -> [b]
  78 movingAverage steps xs = pm mean $ chunkAlong steps 1 xs
  79
  80 ma :: [Double] -> [Double]
  81 ma = movingAverage 3
  82
  83
  84 -- | Function to split a range into chunks
  85 chunkAlong :: Int -> Int -> [a] -> [[a]]
  86 chunkAlong a b l = only (while  dropAlong)
  87     where
  88         only      = pm (take a)
  89         while     = takeWhile  (\x -> length x >= a)
  90         dropAlong = L.scanl (\x _y -> drop b x) l ([1..] :: [Integer])
  91
  92 -- | Optimized version (Vector)
  93 chunkAlong' :: Int -> Int -> V.Vector a -> V.Vector (V.Vector a)
  94 chunkAlong' a b l = only (while  dropAlong)
  95     where
  96         only      = V.map (V.take a)
  97         while     = V.takeWhile  (\x -> V.length x >= a)
  98         dropAlong = V.scanl (\x _y -> V.drop b x) l (V.fromList [1..])
  99
 100 -- | TODO Inverse of chunk ? unchunkAlong ?
 101 unchunkAlong :: Int -> Int -> [[a]] -> [a]
 102 unchunkAlong = undefined
 103
 104
 105 -- splitAlong [2,3,4] ("helloworld" :: [Char]) == ["he", "llo", "worl", "d"]
 106 splitAlong :: [Int] -> [Char] -> [[Char]]
 107 splitAlong _ [] = [] -- No list? done
 108 splitAlong [] xs = [xs] -- No place to split at? Return the remainder
 109 splitAlong (x:xs) ys = take x ys : splitAlong xs (drop x ys) -- take until our split spot, recurse with next split spot and list remainder
 110
 111 takeWhileM :: (Monad m) => (a -> Bool) -> [m a] -> m [a]
 112 takeWhileM _ [] = return []
 113 takeWhileM p (a:as) = do
 114     v <- a
 115     if p v
 116         then do
 117             vs <- takeWhileM p as
 118             return (v:vs)
 119         else return []
 120
 121 -- SUMS
 122 -- To select the right algorithme according to the type:
 123 -- https://github.com/mikeizbicki/ifcxt
 124
 125 sumSimple :: Num a => [a] -> a
 126 sumSimple = L.foldl' (+) 0
 127
 128 -- | https://en.wikipedia.org/wiki/Kahan_summation_algorithm
 129 sumKahan :: Num a => [a] -> a
 130 sumKahan = snd . L.foldl' go (0,0)
 131     where
 132         go (c,t) i = ((t'-t)-y,t')
 133             where
 134                 y  = i-c
 135                 t' = t+y
 136
 137 -- | compute part of the dict
 138 count2map :: (Ord k, Foldable t) => t k -> Map.Map k Double
 139 count2map xs = Map.map (/ (fromIntegral (length xs))) (count2map' xs)
 140
 141 -- | insert in a dict
 142 count2map' :: (Ord k, Foldable t) => t k -> Map.Map k Double
 143 count2map' xs = L.foldl' (\x y -> Map.insertWith' (+) y 1 x) Map.empty xs
 144
 145
 146 trunc :: (RealFrac a, Integral c, Integral b) => b -> a -> c
 147 trunc n = truncate . (* 10^n)
 148
 149 trunc' :: Int -> Double -> Double
 150 trunc' n x = fromIntegral $ truncate $ (x * 10^n)
 151
 152
 153 bool2int :: Num a => Bool -> a
 154 bool2int b = case b of
 155                   True  -> 1
 156                   False -> 0
 157
 158 bool2double :: Bool -> Double
 159 bool2double bool = case bool of
 160                   True  -> 1.0
 161                   False -> 0.0
 162
 163
 164
 165 -- Normalizing && scaling data
 166 scale :: [Double] -> [Double]
 167 scale = scaleMinMax
 168
 169 scaleMinMax :: [Double] -> [Double]
 170 scaleMinMax xs = pm (\x -> (x - mi / (ma - mi + 1) )) xs'
 171     where
 172         ma  = maximum xs'
 173         mi  = minimum xs'
 174         xs' = pm abs xs
 175
 176 scaleNormalize :: [Double] -> [Double]
 177 scaleNormalize xs = pm (\x -> (x - v / (m + 1))) xs'
 178     where
 179         v = variance xs'
 180         m = mean     xs'
 181         xs' = pm abs xs
 182
 183
 184
 185 normalize :: [Double] -> [Double]
 186 normalize as = normalizeWith identity as
 187
 188 normalizeWith :: Fractional b => (a -> b) -> [a] -> [b]
 189 normalizeWith extract bs = pm (\x -> x/(sum bs')) bs'
 190     where
 191         bs' = pm extract bs
 192
 193 -- Zip functions to add
 194 zipFst :: ([b] -> [a]) -> [b] -> [(a, b)]
 195 zipFst  f xs = zip (f xs) xs
 196
 197 zipSnd :: ([a] -> [b]) -> [a] -> [(a, b)]
 198 zipSnd f xs = zip xs (f xs)