2 Module : Gargantext.Prelude
3 Description : Specific Prelude of the project
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
12 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
13 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
16 module Gargantext.Prelude
17 ( module Gargantext.Prelude
20 , module GHC.Err.Located
33 import Control.Monad.Base (MonadBase(..))
34 import GHC.Exts (sortWith)
35 import GHC.Err.Located (undefined)
36 import GHC.Real (round)
37 import Data.Map (Map, lookup)
38 import Data.Maybe (isJust, fromJust, maybe)
39 import Data.Text (Text)
40 import Data.Typeable (Typeable)
41 import Protolude ( Bool(True, False), Int, Int64, Double, Integer
42 , Fractional, Num, Maybe(Just,Nothing)
43 , Enum, Bounded, Float
45 , pure, (>>=), (=<<), (<*>), (<$>), (<&>), (>>)
47 , Ord, Integral, Foldable, RealFrac, Monad, filter
48 , reverse, map, mapM, zip, drop, take, zipWith
49 , sum, fromIntegral, length, fmap, foldl, foldl'
50 , takeWhile, sqrt, identity
51 , abs, min, max, maximum, minimum, return, snd, truncate
52 , (+), (*), (/), (-), (.), ($), (&), (**), (^), (<), (>), log
53 , Eq, (==), (>=), (<=), (<>), (/=)
54 , (&&), (||), not, any, all
57 , elem, die, mod, div, const, either
58 , curry, uncurry, repeat
67 import Prelude (Enum, Bounded, minBound, maxBound, putStrLn)
68 -- TODO import functions optimized in Utils.Count
69 -- import Protolude hiding (head, last, all, any, sum, product, length)
70 -- import Gargantext.Utils.Count
71 import qualified Data.List as L hiding (head, sum)
72 import qualified Control.Monad as M
73 import qualified Data.Map as M
74 import Data.Map.Strict (insertWith)
75 import qualified Data.Vector as V
76 import Safe (headMay, lastMay, initMay, tailMay)
77 import Text.Show (Show(), show)
78 import Text.Read (Read())
79 import Data.String.Conversions (cs)
82 printDebug :: (Show a, MonadBase IO m) => [Char] -> a -> m ()
83 printDebug msg x = liftBase . putStrLn $ msg <> " " <> show x
84 -- printDebug _ _ = pure ()
87 -- | splitEvery n == chunkAlong n n
88 splitEvery :: Int -> [a] -> [[a]]
91 let (h,t) = L.splitAt n xs
97 -- | Function to split a range into chunks
98 -- if step == grain then linearity (splitEvery)
99 -- elif step < grain then overlapping
100 -- else dotted with holes
101 -- TODO FIX BUG if Steps*Grain /= length l
102 -- chunkAlong 10 10 [1..15] == [1..10]
103 -- BUG: what about the rest of (divMod 15 10)?
104 -- TODO: chunkAlongNoRest or chunkAlongWithRest
105 -- default behavior: NoRest
107 chunkAlong :: Eq a => Grain -> Step -> [a] -> [[a]]
108 chunkAlong a b l = case a >= length l of
110 False -> chunkAlong' a b l
112 chunkAlong' :: Eq a => Grain -> Step -> [a] -> [[a]]
113 chunkAlong' a b l = case a > 0 && b > 0 of
114 True -> chunkAlong'' a b l
115 False -> panic "ChunkAlong: Parameters should be > 0 and Grain > Step"
117 chunkAlong'' :: Eq a => Int -> Int -> [a] -> [[a]]
118 chunkAlong'' a b l = filter (/= []) $ only (while dropAlong)
121 while = takeWhile (\x -> length x >= a)
122 dropAlong = L.scanl (\x _y -> drop b x) l ([1..] :: [Integer])
124 -- | Optimized version (Vector)
125 chunkAlongV :: Int -> Int -> V.Vector a -> V.Vector (V.Vector a)
126 chunkAlongV a b l = only (while dropAlong)
128 only = V.map (V.take a)
129 while = V.takeWhile (\x -> V.length x >= a)
130 dropAlong = V.scanl (\x _y -> V.drop b x) l (V.fromList [1..])
132 -- | TODO Inverse of chunk ? unchunkAlong ?
133 -- unchunkAlong :: Int -> Int -> [[a]] -> [a]
134 -- unchunkAlong = undefined
137 -- splitAlong [2,3,4] ("helloworld" :: [Char]) == ["he", "llo", "worl", "d"]
138 splitAlong :: [Int] -> [Char] -> [[Char]]
139 splitAlong _ [] = [] -- No list? done
140 splitAlong [] xs = [xs] -- No place to split at? Return the remainder
141 splitAlong (x:xs) ys = take x ys : splitAlong xs (drop x ys)
142 -- take until our split spot, recurse with next split spot and list remainder
144 takeWhileM :: (Monad m) => (a -> Bool) -> [m a] -> m [a]
145 takeWhileM _ [] = return []
146 takeWhileM p (a:as) = do
150 vs <- takeWhileM p as
155 -- To select the right algorithme according to the type:
156 -- https://github.com/mikeizbicki/ifcxt
158 sumSimple :: Num a => [a] -> a
159 sumSimple = L.foldl' (+) 0
161 -- | https://en.wikipedia.org/wiki/Kahan_summation_algorithm
162 sumKahan :: Num a => [a] -> a
163 sumKahan = snd . L.foldl' go (0,0)
165 go (c,t) i = ((t'-t)-y,t')
170 -- | compute part of the dict
171 count2map :: (Ord k, Foldable t) => t k -> Map k Double
172 count2map xs = M.map (/ (fromIntegral (length xs))) (count2map' xs)
174 -- | insert in a dict
175 count2map' :: (Ord k, Foldable t) => t k -> Map k Double
176 count2map' xs = L.foldl' (\x y -> insertWith (+) y 1 x) M.empty xs
178 trunc :: (RealFrac a, Integral c, Integral b) => b -> a -> c
179 trunc n = truncate . (* 10^n)
181 trunc' :: Int -> Double -> Double
182 trunc' n x = fromIntegral $ truncate $ (x * 10^n)
184 ------------------------------------------------------------------------
185 bool2num :: Num a => Bool -> a
189 bool2double :: Bool -> Double
190 bool2double = bool2num
192 bool2int :: Bool -> Int
194 ------------------------------------------------------------------------
196 -- Normalizing && scaling data
197 scale :: [Double] -> [Double]
200 scaleMinMax :: [Double] -> [Double]
201 scaleMinMax xs = map (\x -> (x - mi / (ma - mi + 1) )) xs'
207 scaleNormalize :: [Double] -> [Double]
208 scaleNormalize xs = map (\x -> (x - v / (m + 1))) xs'
214 normalize :: [Double] -> [Double]
215 normalize as = normalizeWith identity as
217 normalizeWith :: Fractional b => (a -> b) -> [a] -> [b]
218 normalizeWith extract bs = map (\x -> x/(sum bs')) bs'
222 -- Zip functions to add
223 zipFst :: ([b] -> [a]) -> [b] -> [(a, b)]
224 zipFst f xs = zip (f xs) xs
226 zipSnd :: ([a] -> [b]) -> [a] -> [(a, b)]
227 zipSnd f xs = zip xs (f xs)
230 maximumWith :: (Ord a1, Foldable t) => (a2 -> a1) -> t a2 -> a2
231 maximumWith f = L.maximumBy (compare `on` f)
233 -- | To get all combinations of a list with no
234 -- repetition and apply a function to the resulting list of pairs
235 listToCombi :: forall a b. (a -> b) -> [a] -> [(b,b)]
236 listToCombi f l = [ (f x, f y) | (x:rest) <- L.tails l, y <- rest ]
238 ------------------------------------------------------------------------
239 -- Empty List Sugar Error Handling
240 -- TODO add Garg Monad Errors
242 listSafe1 :: Text -> ([a] -> Maybe a)
244 listSafe1 s f e xs = maybe (panic $ h <> e) identity (f xs)
246 h = "[ERR][Gargantext] Empty list for " <> s <> " in "
248 head' :: Text -> [a] -> a
249 head' = listSafe1 "head" headMay
251 last' :: Text -> [a] -> a
252 last' = listSafe1 "last" lastMay
254 ------------------------------------------------------------------------
256 listSafeN :: Text -> ([a] -> Maybe [a])
257 -> Text -> [a] -> [a]
258 listSafeN s f e xs = maybe (panic $ h <> e) identity (f xs)
260 h = "[ERR][Gargantext] Empty list for " <> s <> " in "
262 tail' :: Text -> [a] -> [a]
263 tail' = listSafeN "tail" tailMay
265 init' :: Text -> [a] -> [a]
266 init' = listSafeN "init" initMay
268 ------------------------------------------------------------------------
269 --- Some Statistics sugar functions
270 -- Exponential Average
271 eavg :: [Double] -> Double
272 eavg (x:xs) = a*x + (1-a)*(eavg xs)
277 mean :: Fractional a => [a] -> a
278 mean xs = sum xs / fromIntegral (length xs)
280 sumMaybe :: Num a => [Maybe a] -> Maybe a
281 sumMaybe = fmap sum . M.sequence
283 variance :: Floating a => [a] -> a
284 variance xs = sum ys / (fromIntegral (length xs) - 1)
287 ys = map (\x -> (x - m) ** 2) xs
289 deviation :: Floating a => [a] -> a
290 deviation = sqrt . variance
292 movingAverage :: (Eq b, Fractional b) => Int -> [b] -> [b]
293 movingAverage steps xs = map mean $ chunkAlong steps 1 xs
295 ma :: [Double] -> [Double]
298 -----------------------------------------------------------------------
299 -----------------------------------------------------------------------
300 --- Map in Map = Map2
301 -- To avoid Map (a,a) b
302 type Map2 a b = Map a (Map a b)
313 -----------------------------------------------
315 foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
316 foldM' _ z [] = return z
317 foldM' f z (x:xs) = do
319 z' `seq` foldM' f z' xs