[SECURITY] newtype GargPassword with Show hidden.
[gargantext.git] / src / Gargantext / Viz / Phylo / Aggregates.hs
index 4cfb6e6cdaceba778c85e060f4a868b59e27a611..bfc4e93283372a63d0210526c8a6f238bddee9bf 100644 (file)
@@ -17,8 +17,7 @@ Portability : POSIX
 module Gargantext.Viz.Phylo.Aggregates
   where
 
-
-import Control.Lens hiding (makeLenses, both, Level)
+import Control.Parallel.Strategies
 
 import Gargantext.Prelude hiding  (elem)
 import Gargantext.Text.Context    (TermList)
@@ -28,13 +27,16 @@ import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
 
 import Debug.Trace (trace)
-import Data.List    (partition, concat, nub, elem, sort, (++), null)
-import Data.Map     (Map, fromList, fromListWith, adjust, filterWithKey, toList, elems, keys, unionWith, mapWithKey)
+
+import Data.List    (partition, concat, nub, elem, sort, (++), null, union)
+import Data.Map     (Map, fromList, fromListWith, adjust, filterWithKey, elems, keys, unionWith, mapWithKey)
 import Data.Set     (size)
 import Data.Text    (Text, unwords)
 import Data.Vector  (Vector)
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
 import qualified Data.Vector as Vector
 
 
@@ -43,21 +45,23 @@ import qualified Data.Vector as Vector
 -- | Foundations | --
 ---------------------
 
-
 -- | Extract all the labels of a termList
 termListToNgrams :: TermList -> [Ngrams]
-termListToNgrams l = map (\(lbl,_) -> unwords lbl) l
+termListToNgrams = map (\(lbl,_) -> unwords lbl)
 
 
 -------------------
 -- | Documents | --
 -------------------
 
-
 -- | To group a list of Documents by fixed periods
-groupDocsByPeriod :: (Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
+groupDocsByPeriod :: (NFData doc, Ord date, Enum date) => (doc -> date) -> [(date,date)] -> [doc] -> Map (date, date) [doc]
 groupDocsByPeriod _ _   [] = panic "[ERR][Viz.Phylo.Example.docsToPeriods] Empty [Documents] can not have any periods"
-groupDocsByPeriod f pds es = trace ("----\nGroup docs by periods\n") $ fromList $ zip pds $ map (inPeriode f es) pds
+groupDocsByPeriod f pds es = 
+  let periods  = map (inPeriode f es) pds
+      periods' = periods `using` parList rdeepseq
+
+  in  trace ("----\nGroup docs by periods\n") $ fromList $ zip pds periods'
   where
     --------------------------------------
     inPeriode :: Ord b => (t -> b) -> [t] -> (b, b) -> [t]
@@ -84,7 +88,7 @@ countDocs corpus = fromListWith (+) $ map (\(d,_) -> (d,1)) corpus
 
 -- | To init a list of Periods framed by a starting Date and an ending Date
 initPeriods :: (Eq date, Enum date) => Grain -> Step -> (date, date) -> [(date, date)]
-initPeriods g s (start,end) = map (\l -> (head' "Doc" l, last' "Doc" l))
+initPeriods g s (start,end) = map (\l -> (head' "initPeriods" l, last' "initPeriods" l))
                             $ chunkAlong g s [start .. end]
 
 
@@ -163,28 +167,45 @@ filterFisByClique :: Int -> [PhyloFis] -> [PhyloFis]
 filterFisByClique thr l = filter (\fis -> (size $ getClique fis) >= thr) l
 
 
--- | To filter nested Fis 
+-- | To find if l' is nested in l
+isNested :: Eq a => [a] -> [a] -> Bool
+isNested l l'
+  | null l'               = True
+  | length l' > length l  = False
+  | (union  l l') == l    = True
+  | otherwise             = False 
+
+
+-- | To filter nested Fis
 filterFisByNested :: Map (Date, Date) [PhyloFis] -> Map (Date, Date) [PhyloFis]
-filterFisByNested = map (\l -> let cliqueMax = filterNestedSets (head' "Fis" $ map getClique l) (map getClique l) []
-                               in  filter (\fis -> elem (getClique fis) cliqueMax) l)
+filterFisByNested m = 
+  let fis  = map (\l -> 
+                foldl (\mem f -> if (any (\f' -> isNested (Set.toList $ getClique f') (Set.toList $ getClique f)) mem)
+                                 then mem
+                                 else 
+                                    let fMax = filter (\f' -> not $ isNested (Set.toList $ getClique f) (Set.toList $ getClique f')) mem
+                                    in  fMax ++ [f] ) [] l)
+           $ elems m 
+      fis' = fis `using` parList rdeepseq
+  in  fromList $ zip (keys m) fis' 
 
 
 -- | Choose if we use a set of Fis from a file or if we have to create them
-docsToFis :: Map (Date,Date) [Document] -> Phylo -> Phylo
+docsToFis :: Map (Date,Date) [Document] -> Phylo -> Map (Date, Date) [PhyloFis]
 docsToFis m p = if (null $ getPhyloFis p)
                  then trace("----\nRebuild the Fis from scratch\n") 
-                    $ p & phylo_fis .~ mapWithKey (\k docs -> let fis = toList $ fisWithSizePolyMap (Segment 1 20) 1 (map text docs)
+                    $ mapWithKey (\k docs -> let fis = Map.toList $ fisWithSizePolyMap (Segment 1 20) 1 (map text docs)
                                                               in map (\f -> PhyloFis (fst f) (snd f) k) fis) m
                  else trace("----\nUse Fis from an existing file\n") 
-                    $ p & phylo_fis %~ (unionWith (++) (fromList $ map (\k -> (k,[])) $ keys m))
+                    $ unionWith (++) (fromList $ map (\k -> (k,[])) $ keys m) (getPhyloFis p)
 
 
 -- | Process some filters on top of a set of Fis
 refineFis :: Map (Date, Date) [PhyloFis] -> Bool -> Support -> Int -> Map (Date, Date) [PhyloFis]
-refineFis fis k s t = traceFis "----\nFiltered Fis by clique size :\n"
-                      $ filterFis k t (filterFisByClique)
-                      $ traceFis "----\nFiltered Fis by nested :\n"
+refineFis fis k s t = traceFis "----\nFiltered Fis by nested :\n"
                       $ filterFisByNested 
+                      $ traceFis "----\nFiltered Fis by clique size :\n"                      
+                      $ filterFis k t (filterFisByClique)
                       $ traceFis "----\nFiltered Fis by support :\n"
                       $ filterFis k s (filterFisBySupport)
                       $ traceFis "----\nUnfiltered Fis :\n" fis
@@ -220,4 +241,4 @@ traceFis lbl m = trace (lbl <> "count : " <> show (sum $ map length $ elems m) <
     --------------------------------------
     ngrms :: [Double]
     ngrms = sort $ map (\f -> fromIntegral $ size $ _phyloFis_clique f) $ concat $ elems m
-    --------------------------------------
\ No newline at end of file
+    --------------------------------------