Merge branch 'dev-phylo' of...

Merge branch 'dev-phylo' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantext into dev-phylo

bin/gargantext-adaptative-phylo/Main.hs

@@ -166,7 +166,7 @@ main = do
 
             let clq = case (clique config) of
                         Fis s s' -> "fis_" <> (show s) <> "_" <> (show s')
-                        MaxClique s ->  "clique_" <> (show s)
+                        MaxClique s _ _ ->  "clique_" <> (show s)
 
             let sensibility = case (phyloProximity config) of
                         Hamming -> undefined

src/Gargantext/Core/Viz/AdaptativePhylo.hs

@@ -108,13 +108,16 @@ data TimeUnit =
       , _year_matchingFrame :: Int }
       deriving (Show,Generic,Eq) 
 
+data CliqueFilter = ByThreshold | ByNeighbours deriving (Show,Generic,Eq)
 
 data Clique = 
       Fis 
       { _fis_support :: Int
       , _fis_size    :: Int }
     | MaxClique
-      { _mcl_size :: Int } 
+      { _mcl_size      :: Int
+      , _mcl_threshold :: Double
+      , _mcl_filter    :: CliqueFilter } 
       deriving (Show,Generic,Eq)      
 
 
@@ -155,10 +158,10 @@ defaultConfig =
             , phyloProximity = WeightedLogJaccard 10
             , seaElevation   = Constante 0.1 0.1
             , findAncestors  = True
-            , phyloSynchrony = ByProximityThreshold 0.2 10 SiblingBranches MergeAllGroups
+            , phyloSynchrony = ByProximityThreshold 0.1 10 SiblingBranches MergeAllGroups
             , phyloQuality   = Quality 0 1
             , timeUnit       = Year 3 1 5
-            , clique         = MaxClique 0
+            , clique         = MaxClique 0 3 ByNeighbours
             , exportLabel    = [BranchLabel MostEmergentTfIdf 2, GroupLabel MostEmergentInclusive 2]
             , exportSort     = ByHierarchy
             , exportFilter   = [ByBranchSize 2]  
@@ -174,6 +177,8 @@ instance FromJSON SeaElevation
 instance ToJSON SeaElevation
 instance FromJSON TimeUnit
 instance ToJSON TimeUnit
+instance FromJSON CliqueFilter
+instance ToJSON CliqueFilter
 instance FromJSON Clique
 instance ToJSON Clique
 instance FromJSON PhyloLabel

src/Gargantext/Core/Viz/Graph/MaxClique.hs

@@ -60,17 +60,19 @@ import Data.Set (Set)
 import Data.Set (fromList, toList, isSubsetOf)
 import Data.Graph.Inductive hiding (Graph, neighbors, subgraph, (&))
 import Gargantext.Core.Viz.Graph.FGL (Graph_Undirected, degree, neighbors, mkGraphUfromEdges)
-import Gargantext.Core.Viz.Graph.Tools (cooc2graph', Threshold)
+import Gargantext.Core.Viz.Graph.Tools (cooc2graph',cooc2graph'', Threshold)
 import Gargantext.Core.Viz.Graph.Distances (Distance)
 import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex)
+import Gargantext.Core.Viz.AdaptativePhylo
+-- import Debug.Trace (trace)
 type Graph = Graph_Undirected
 type Neighbor = Node
 
 
 -- | getMaxCliques
 -- TODO chose distance order
-getMaxCliques :: Ord a => Distance -> Threshold -> Map (a, a) Int -> [[a]]
-getMaxCliques d t m = map fromIndices $ getMaxCliques' t m'
+getMaxCliques :: Ord a => CliqueFilter -> Distance -> Threshold -> Map (a, a) Int -> [[a]]
+getMaxCliques f d t m = map fromIndices $ getMaxCliques' t m'
   where
     m'          = toIndex to m
     (to,from)   = createIndices m
@@ -80,7 +82,10 @@ getMaxCliques d t m = map fromIndices $ getMaxCliques' t m'
     getMaxCliques' t' n = maxCliques graph
       where
         graph = mkGraphUfromEdges (Map.keys n')
-        n'    = cooc2graph' d t' n
+        -- n'    = cooc2graph' d t' n
+        n'    = case f of ByThreshold  -> cooc2graph'  d t' n
+                          ByNeighbours -> cooc2graph'' d t' n
+
 
 maxCliques :: Graph -> [[Node]]
 maxCliques g = map (\n -> subMaxCliques g (n:ns)) ns & concat & takeMax

src/Gargantext/Core/Viz/Graph/Tools.hs

@@ -35,6 +35,7 @@ import qualified IGraph.Algorithms.Layout as Layout
 import qualified Data.Vector.Storable as Vec
 import qualified Data.Map  as Map
 import qualified Data.List as List
+-- import Debug.Trace (trace)
 
 type Threshold = Double
 
@@ -52,6 +53,39 @@ cooc2graph' distance threshold myCooc = distanceMap
     distanceMap = Map.filter (> threshold) $ mat2map distanceMat
 
 
+cooc2graph'' :: Ord t => Distance
+                      -> Double
+                      -> Map (t, t) Int
+                      -> Map (Index, Index) Double
+cooc2graph'' distance threshold myCooc = neighbouMap
+  where
+    (ti, _) = createIndices myCooc
+    myCooc' = toIndex ti myCooc
+    matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
+    distanceMat = measure distance matCooc
+    neighbouMap = filterByNeighbours threshold
+                $ mat2map distanceMat
+
+
+-- Quentin
+filterByNeighbours :: Double -> Map (Index, Index) Double -> Map (Index, Index) Double
+filterByNeighbours threshold distanceMap = filteredMap
+  where 
+    indexes :: [Index]
+    indexes = List.nub $ List.concat $ map (\(idx,idx') -> [idx,idx'] ) $ Map.keys distanceMap
+    filteredMap :: Map (Index, Index) Double
+    filteredMap = Map.fromList
+                $ List.concat 
+                $ map (\idx -> 
+                          let selected = List.reverse
+                                       $ List.sortOn snd
+                                       $ Map.toList 
+                                       $ Map.filter (> 0)
+                                       $ Map.filterWithKey (\(from,_) _ -> idx == from) distanceMap
+                           in List.take (round threshold) selected
+                      ) indexes                 
+
+
 cooc2graph :: Distance
            -> Threshold
            -> (Map (Text, Text) Int)

src/Gargantext/Core/Viz/Phylo/PhyloExample.hs

@@ -104,7 +104,7 @@ config =
     defaultConfig { phyloName  = "Cesar et Cleopatre"
                   , phyloLevel = 2
                   , exportFilter = [ByBranchSize 0]
-                  , clique = MaxClique 0 }
+                  , clique = MaxClique 0 3 ByNeighbours }
 
 
 docs :: [Document]

src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs

@@ -203,8 +203,8 @@ toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of
                  $ filterClique True s (filterCliqueBySupport)
                  {- \$ traceFis "Unfiltered Fis" -}
                  phyloClique
-    MaxClique s -> filterClique True s (filterCliqueBySize)
-                 phyloClique
+    MaxClique s _ _ -> filterClique True s (filterCliqueBySize)
+                       phyloClique
     where
         -------------------------------------- 
         phyloClique :: Map (Date,Date) [PhyloClique]
@@ -216,13 +216,13 @@ toPhyloClique phylo phyloDocs = case (clique $ getConfig phylo) of
                                $ toList phyloDocs
                           fis' = fis `using` parList rdeepseq
                        in fromList fis'
-          MaxClique _ -> 
+          MaxClique _ thr filterType -> 
                       let mcl  = map (\(prd,docs) -> 
                                     let cooc = map round
                                              $ foldl sumCooc empty
                                              $ map listToMatrix 
                                              $ map (\d -> ngramsToIdx (text d) (getRoots phylo)) docs
-                                     in (prd, map (\cl -> PhyloClique cl 0 prd) $ getMaxCliques Conditional 0.001 cooc)) 
+                                     in (prd, map (\cl -> PhyloClique cl 0 prd) $ getMaxCliques filterType Conditional thr cooc)) 
                                $ toList phyloDocs
                           mcl' = mcl `using` parList rdeepseq                               
                        in fromList mcl' 

src/Gargantext/Core/Viz/Phylo/PhyloTools.hs

@@ -225,12 +225,12 @@ traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map l
 getCliqueSupport :: Clique -> Int
 getCliqueSupport unit = case unit of 
     Fis s _ -> s
-    MaxClique _ -> 0
+    MaxClique _ _ _ -> 0
 
 getCliqueSize :: Clique -> Int
 getCliqueSize unit = case unit of 
     Fis _ s -> s
-    MaxClique s -> s
+    MaxClique s _ _ -> s
 
 
 --------------

src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs

@@ -190,13 +190,13 @@ synchronicClustering phylo =
         sync = phyloSynchrony $ getConfig phylo
         docs = phylo ^. phylo_timeDocs
         diagos = map coocToDiago $ phylo ^. phylo_timeCooc
-        newBranches  = map (\branch -> levelUpAncestors $ reduceGroups prox sync docs diagos branch) 
+        newBranches  = map (\branch -> reduceGroups prox sync docs diagos branch) 
                      $ map processDynamics
                      $ adjustClustering sync
                      $ phyloToLastBranches 
                      $ traceSynchronyStart phylo
         newBranches' = newBranches `using` parList rdeepseq
-     in toNextLevel' phylo $ concat newBranches'
+     in toNextLevel' phylo $ levelUpAncestors $ concat newBranches'
 
 
 -- synchronicDistance :: Phylo -> Level -> String