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