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