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