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