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