src/Gargantext/Prelude.hs

   1 {-|
   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
   8 Portability : POSIX
   9
  10 Here is a longer description of this module, containing some
  11 commentary with @some markup@.
  12 -}
  13
  14 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  15 {-# OPTIONS_GHC -fno-warn-type-defaults  #-}
  16
  17 {-# LANGUAGE     NoImplicitPrelude       #-}
  18 {-# LANGUAGE     OverloadedStrings       #-}
  19 {-# LANGUAGE     RankNTypes              #-}
  20
  21 module Gargantext.Prelude
  22   ( module Gargantext.Prelude
  23   , module Protolude
  24   , headMay, lastMay
  25   , module GHC.Err.Located
  26   , module Text.Show
  27   , module Text.Read
  28   , cs
  29   , module Data.Maybe
  30   , round
  31   , sortWith
  32   , module Prelude
  33   )
  34   where
  35
  36 import GHC.Exts (sortWith)
  37 import GHC.Err.Located (undefined)
  38 import GHC.Real (round)
  39 import Control.Monad.IO.Class (MonadIO)
  40 import Data.Maybe (isJust, fromJust, maybe)
  41 import Data.Text (Text)
  42 import Protolude ( Bool(True, False), Int, Int64, Double, Integer
  43                  , Fractional, Num, Maybe(Just,Nothing)
  44                  , Enum, Bounded, Float
  45                  , Floating, Char, IO
  46                  , pure, (>>=), (=<<), (<*>), (<$>)
  47                  , putStrLn
  48                  , head, flip
  49                  , Ord, Integral, Foldable, RealFrac, Monad, filter
  50                  , reverse, map, mapM, zip, drop, take, zipWith
  51                  , sum, fromIntegral, length, fmap, foldl, foldl'
  52                  , takeWhile, sqrt, identity
  53                  , abs, min, max, maximum, minimum, return, snd, truncate
  54                  , (+), (*), (/), (-), (.), ($), (&), (**), (^), (<), (>), log
  55                  , Eq, (==), (>=), (<=), (<>), (/=)
  56                  , (&&), (||), not, any, all
  57                  , fst, snd, toS
  58                  , elem, die, mod, div, const, either
  59                  , curry, uncurry, repeat
  60                  , otherwise, when
  61                  , IO()
  62                  , compare
  63                  , on
  64                  , panic
  65                  )
  66
  67 import Prelude (Enum, Bounded, minBound, maxBound)
  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
  74 import Data.Map (Map)
  75 import qualified Data.Map as M
  76
  77 import Data.Map.Strict (insertWith)
  78 import qualified Data.Vector as V
  79 import Safe (headMay, lastMay, initMay, tailMay)
  80 import Text.Show (Show(), show)
  81 import Text.Read (Read())
  82 import Data.String.Conversions (cs)
  83
  84
  85 printDebug :: (Show a, MonadIO m) => [Char] -> a -> m ()
  86 printDebug msg x = putStrLn $ msg <> " " <> show x
  87 -- printDebug _ _ = pure ()
  88
  89
  90 map2 :: (t -> b) -> [[t]] -> [[b]]
  91 map2 fun = map (map fun)
  92
  93
  94 -- Some Statistics sugar functions
  95 -- Exponential Average
  96 eavg :: [Double] -> Double
  97 eavg (x:xs) = a*x + (1-a)*(eavg xs)
  98   where a = 0.70
  99 eavg [] = 0
 100
 101 -- Simple Average
 102 mean :: Fractional a => [a] -> a
 103 mean xs = sum xs / fromIntegral (length xs)
 104
 105
 106 sumMaybe :: Num a => [Maybe a] -> Maybe a
 107 sumMaybe = fmap sum . M.sequence
 108
 109 variance :: Floating a => [a] -> a
 110 variance xs = sum ys  / (fromIntegral (length xs) - 1)
 111   where
 112     m = mean xs
 113     ys = map (\x -> (x - m) ** 2) xs
 114
 115
 116 deviation :: Floating a => [a] -> a
 117 deviation = sqrt . variance
 118
 119 movingAverage :: (Eq b, Fractional b) => Int -> [b] -> [b]
 120 movingAverage steps xs = map mean $ chunkAlong steps 1 xs
 121
 122 ma :: [Double] -> [Double]
 123 ma = movingAverage 3
 124
 125 -- | splitEvery n == chunkAlong n n
 126 splitEvery :: Int -> [a] -> [[a]]
 127 splitEvery _ [] = []
 128 splitEvery n xs =
 129   let (h,t) = L.splitAt n xs
 130   in  h : splitEvery n t
 131
 132 type Grain = Int
 133 type Step  = Int
 134
 135 -- | Function to split a range into chunks
 136 -- if   step == grain then linearity (splitEvery)
 137 -- elif step < grain then overlapping
 138 -- else dotted with holes
 139 -- TODO FIX BUG if Steps*Grain /= length l
 140 -- chunkAlong 10 10 [1..15] == [1..10]
 141 -- BUG: what about the rest of (divMod 15 10)?
 142 -- TODO: chunkAlongNoRest or chunkAlongWithRest
 143 -- default behavior: NoRest
 144
 145 chunkAlong :: Eq a => Grain -> Step -> [a] -> [[a]]
 146 chunkAlong a b l = case a >= length l of
 147   True  -> [l]
 148   False -> chunkAlong' a b l
 149
 150 chunkAlong' :: Eq a => Grain -> Step -> [a] -> [[a]]
 151 chunkAlong' a b l = case a > 0 && b > 0 of
 152   True  -> chunkAlong'' a b l
 153   False -> panic "ChunkAlong: Parameters should be > 0 and Grain > Step"
 154
 155 chunkAlong'' :: Eq a => Int -> Int -> [a] -> [[a]]
 156 chunkAlong'' a b l = filter (/= []) $ only (while dropAlong)
 157   where
 158     only      = map       (take a)
 159     while     = takeWhile (\x -> length x >= a)
 160     dropAlong = L.scanl   (\x _y -> drop b x) l ([1..] :: [Integer])
 161
 162 -- | Optimized version (Vector)
 163 chunkAlongV :: Int -> Int -> V.Vector a -> V.Vector (V.Vector a)
 164 chunkAlongV a b l = only (while  dropAlong)
 165   where
 166     only      = V.map       (V.take a)
 167     while     = V.takeWhile (\x -> V.length x >= a)
 168     dropAlong = V.scanl     (\x _y -> V.drop b x) l (V.fromList [1..])
 169
 170 -- | TODO Inverse of chunk ? unchunkAlong ?
 171 -- unchunkAlong :: Int -> Int -> [[a]] -> [a]
 172 -- unchunkAlong = undefined
 173
 174
 175 -- splitAlong [2,3,4] ("helloworld" :: [Char]) == ["he", "llo", "worl", "d"]
 176 splitAlong :: [Int] -> [Char] -> [[Char]]
 177 splitAlong _ [] = [] -- No list? done
 178 splitAlong [] xs = [xs] -- No place to split at? Return the remainder
 179 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
 180
 181 takeWhileM :: (Monad m) => (a -> Bool) -> [m a] -> m [a]
 182 takeWhileM _ [] = return []
 183 takeWhileM p (a:as) = do
 184     v <- a
 185     if p v
 186         then do
 187             vs <- takeWhileM p as
 188             return (v:vs)
 189         else return []
 190
 191 -- SUMS
 192 -- To select the right algorithme according to the type:
 193 -- https://github.com/mikeizbicki/ifcxt
 194
 195 sumSimple :: Num a => [a] -> a
 196 sumSimple = L.foldl' (+) 0
 197
 198 -- | https://en.wikipedia.org/wiki/Kahan_summation_algorithm
 199 sumKahan :: Num a => [a] -> a
 200 sumKahan = snd . L.foldl' go (0,0)
 201     where
 202         go (c,t) i = ((t'-t)-y,t')
 203             where
 204                 y  = i-c
 205                 t' = t+y
 206
 207 -- | compute part of the dict
 208 count2map :: (Ord k, Foldable t) => t k -> Map k Double
 209 count2map xs = M.map (/ (fromIntegral (length xs))) (count2map' xs)
 210
 211 -- | insert in a dict
 212 count2map' :: (Ord k, Foldable t) => t k -> Map k Double
 213 count2map' xs = L.foldl' (\x y -> insertWith (+) y 1 x) M.empty xs
 214
 215
 216 trunc :: (RealFrac a, Integral c, Integral b) => b -> a -> c
 217 trunc n = truncate . (* 10^n)
 218
 219 trunc' :: Int -> Double -> Double
 220 trunc' n x = fromIntegral $ truncate $ (x * 10^n)
 221
 222
 223 ------------------------------------------------------------------------
 224 bool2num :: Num a => Bool -> a
 225 bool2num True  = 1
 226 bool2num False = 0
 227
 228 bool2double :: Bool -> Double
 229 bool2double = bool2num
 230
 231 bool2int :: Bool -> Int
 232 bool2int = bool2num
 233 ------------------------------------------------------------------------
 234
 235 -- Normalizing && scaling data
 236 scale :: [Double] -> [Double]
 237 scale = scaleMinMax
 238
 239 scaleMinMax :: [Double] -> [Double]
 240 scaleMinMax xs = map (\x -> (x - mi / (ma - mi + 1) )) xs'
 241     where
 242         ma  = maximum xs'
 243         mi  = minimum xs'
 244         xs' = map abs xs
 245
 246 scaleNormalize :: [Double] -> [Double]
 247 scaleNormalize xs = map (\x -> (x - v / (m + 1))) xs'
 248     where
 249         v   = variance  xs'
 250         m   = mean      xs'
 251         xs' = map abs xs
 252
 253 normalize :: [Double] -> [Double]
 254 normalize as = normalizeWith identity as
 255
 256 normalizeWith :: Fractional b => (a -> b) -> [a] -> [b]
 257 normalizeWith extract bs = map (\x -> x/(sum bs')) bs'
 258     where
 259         bs' = map extract bs
 260
 261 -- Zip functions to add
 262 zipFst :: ([b] -> [a]) -> [b] -> [(a, b)]
 263 zipFst  f xs = zip (f xs) xs
 264
 265 zipSnd :: ([a] -> [b]) -> [a] -> [(a, b)]
 266 zipSnd f xs = zip xs (f xs)
 267
 268 -- | maximumWith
 269 maximumWith :: (Ord a1, Foldable t) => (a2 -> a1) -> t a2 -> a2
 270 maximumWith f = L.maximumBy (compare `on` f)
 271
 272
 273 -- | To get all combinations of a list with no repetition and apply a function to the resulting list of pairs
 274 listToCombi :: forall a b. (a -> b) -> [a] -> [(b,b)]
 275 listToCombi f l = [ (f x, f y) | (x:rest) <- L.tails l,  y <- rest ]
 276
 277 ------------------------------------------------------------------------
 278 -- Empty List Sugar Error Handling
 279 -- TODO add Garg Monad Errors
 280
 281 listSafe1 :: Text -> ([a] -> Maybe a)
 282           -> Text -> [a] -> a
 283 listSafe1 s f e xs = maybe (panic $ h <> e) identity (f xs)
 284   where
 285     h = "[ERR][Gargantext] Empty list for " <> s <> " in "
 286
 287 head' :: Text -> [a] -> a
 288 head' = listSafe1 "head" headMay
 289
 290 last' :: Text -> [a] -> a
 291 last' = listSafe1 "last" lastMay
 292
 293 ------------------------------------------------------------------------
 294
 295 listSafeN :: Text -> ([a] -> Maybe [a])
 296           -> Text -> [a] -> [a]
 297 listSafeN s f e xs = maybe (panic $ h <> e) identity (f xs)
 298   where
 299     h = "[ERR][Gargantext] Empty list for " <> s <> " in "
 300
 301 tail' :: Text -> [a] -> [a]
 302 tail' = listSafeN "tail" tailMay
 303
 304 init' :: Text -> [a] -> [a]
 305 init' = listSafeN "init" initMay
 306