starting working on output views

src/Gargantext/Viz/Phylo.hs

@@ -134,7 +134,7 @@ data PhyloGroup =
                 deriving (Generic, Show, Eq)
 
 data PhyloBranch =
-     PhyloBranch { _phylo_branchId     :: (Int,Int)
+     PhyloBranch { _phylo_branchId     :: (Level,Int)
                  , _phylo_branchLabel  :: Text
                  , _phylo_branchGroups :: [PhyloGroupId] 
                  }
@@ -186,7 +186,7 @@ type Cluster = [PhyloGroup]
 -- | A List of PhyloGroup in a PhyloGraph
 type PhyloNodes = [PhyloGroup]
 -- | A List of weighted links between some PhyloGroups in a PhyloGraph
-type PhyloEdges = [(((PhyloGroup,PhyloGroup)),Weight)]
+type PhyloEdges = [((PhyloGroup,PhyloGroup),Weight)]
 -- | The association as a Graph between a list of Nodes and a list of Edges
 type PhyloGraph = (PhyloNodes,PhyloEdges)
 

src/Gargantext/Viz/Phylo/Aggregates/Cluster.hs

@@ -37,7 +37,7 @@ import qualified Data.Set    as Set
 -- | To apply a Clustering method to a PhyloGraph
 graphToClusters :: (Clustering,[Double]) -> PhyloGraph -> [[PhyloGroup]]
 graphToClusters (clust,param) (nodes,edges) = case clust of 
-  Louvain           -> undefined
+  Louvain           -> louvain (nodes,edges)
   RelatedComponents -> relatedComp 0 (head nodes) (tail nodes,edges) [] []   
 
 

src/Gargantext/Viz/Phylo/BranchMaker.hs

@@ -49,8 +49,12 @@ groupsToGraph (prox,param) groups p = (groups,edges)
       FromPairs          -> (nub . concat) $ map (\g -> (map (\g' -> ((g',g),1)) $ getGroupParents g p)
                                                         ++
                                                         (map (\g' -> ((g,g'),1)) $ getGroupChilds g p)) groups 
-      WeightedLogJaccard -> map (\(x,y) -> ((x,y), weightedLogJaccard 
-                                                   (param !! 0) (getGroupCooc x) 
+      WeightedLogJaccard -> filter (\edge -> snd edge >= (param !! 0)) 
+                          $ map (\(x,y) -> ((x,y), weightedLogJaccard 
+                                (param !! 1) (getGroupCooc x) 
+                                (unifySharedKeys (getGroupCooc x) (getGroupCooc y)))) $ listToDirectedCombi groups
+      Hamming            -> filter (\edge -> snd edge <= (param !! 0)) 
+                          $ map (\(x,y) -> ((x,y), hamming (getGroupCooc x) 
                                 (unifySharedKeys (getGroupCooc x) (getGroupCooc y)))) $ listToDirectedCombi groups                          
       _                  -> undefined 
 

src/Gargantext/Viz/Phylo/Example.hs

@@ -31,14 +31,14 @@ module Gargantext.Viz.Phylo.Example where
 import Control.Lens     hiding (makeLenses, both, Level)
 
 import Data.Bool        (Bool, not)
-import Data.List        (concat, union, intersect, tails, tail, head, last, null, zip, sort, length, any, (++), (!!), nub, sortOn, reverse, splitAt, take, delete, init)
+import Data.List        (concat, union, intersect, tails, tail, head, last, null, zip, sort, length, any, (++), (!!), nub, sortOn, reverse, splitAt, take, delete, init, groupBy)
 import Data.Map         (Map, elems, member, adjust, singleton, empty, (!), keys, restrictKeys, mapWithKey, filterWithKey, mapKeys, intersectionWith, unionWith)
 import Data.Semigroup   (Semigroup)
 import Data.Set         (Set)
 import Data.Text        (Text, unwords, toLower, words)
 import Data.Tuple       (fst, snd)
 import Data.Tuple.Extra
-import Data.Vector      (Vector, fromList, elemIndex)
+import Data.Vector      (Vector, fromList, elemIndex, (!))
 
 import Gargantext.Prelude          hiding (head)
 import Gargantext.Text.Terms.Mono  (monoTexts)
@@ -65,24 +65,74 @@ import qualified Data.Tuple  as Tuple
 import qualified Data.Vector as Vector
 
 
+------------------------------------------------------------------------
+-- | STEP 12 | -- Return a Phylo for upcomming visiualization tasks 
+
+-- mostFreqNgramsVerbose :: Int -> [PhyloGroup] -> PhyloNgrams -> Text
+-- mostFreqNgramsVerbose thr groups ngrams = unwords $ map (\idx -> ngrams Vector.(!) idx) $ mostFreqNgrams thr groups
+
+mostFreqNgrams :: Int -> [PhyloGroup] -> [Int]
+mostFreqNgrams thr groups = map fst 
+                          $ take thr 
+                          $ reverse 
+                          $ sortOn snd 
+                          $ map (\g -> (head g,length g)) 
+                          $ groupBy (==) 
+                          $ (sort . concat) 
+                          $ map getGroupNgrams groups
+
+toPhyloView :: Level -> Phylo -> [PhyloBranch]
+toPhyloView lvl p = branchesLbl 
+  where 
+    branchesLbl = map (\b -> over (phylo_branchLabel) (\lbl -> "toto") b) branches 
+    branches = filter (\b -> (fst . _phylo_branchId) b == lvl) $ getPhyloBranches p 
+
+view1 = toPhyloView 2 phylo3 
+
 ------------------------------------------------------------------------
 -- | STEP 11 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo   
 
 
+phylo6 :: Phylo
+phylo6 = toNthLevel 6 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) (WeightedLogJaccard,[0.01,0]) phylo3  
+
+
+phylo3 :: Phylo
+phylo3 = setPhyloBranches 3
+       $ pairGroupsToGroups Childs  3 (WeightedLogJaccard,[0.01,0])
+       $ pairGroupsToGroups Parents 3 (WeightedLogJaccard,[0.01,0]) 
+       $ setLevelLinks (2,3) 
+       $ addPhyloLevel 3 
+          (phyloToClusters 2 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) phyloBranch2) 
+          phyloBranch2
+
+
 ------------------------------------------------------------------------
 -- | STEP 10 | -- Cluster the Fis
 
+phyloBranch2 :: Phylo
+phyloBranch2 = setPhyloBranches 2 phylo2_c
+
+
+phylo2_c :: Phylo
+phylo2_c = pairGroupsToGroups Childs 2 (WeightedLogJaccard,[0.01,0]) phylo2_p
+
+
+phylo2_p :: Phylo
+phylo2_p = pairGroupsToGroups Parents 2 (WeightedLogJaccard,[0.01,0]) phylo2_1_2
+
+
+phylo2_1_2 :: Phylo
+phylo2_1_2 = setLevelLinks (1,2) phylo2
 
--- | To do : ajouter de nouveaux clusters / proxi
--- gérer les cooc à level 2 et +, idem pour les quality
--- réfléchir aux formats de sortie 
 
+-- | phylo2 allready contains the LevelChilds links from 2 to 1
 phylo2 :: Phylo
 phylo2 = addPhyloLevel 2 phyloCluster phyloBranch1
 
 
 phyloCluster :: Map (Date,Date) [Cluster] 
-phyloCluster = phyloToClusters 1 (WeightedLogJaccard,[0]) (RelatedComponents, []) phyloBranch1
+phyloCluster = phyloToClusters 1 (WeightedLogJaccard,[0.01,0]) (RelatedComponents, []) phyloBranch1
 
 
 ------------------------------------------------------------------------
@@ -98,11 +148,11 @@ phyloBranch1 = setPhyloBranches 1 phylo1_c
 
 
 phylo1_c :: Phylo
-phylo1_c = pairGroupsToGroups Childs 1 0.01 (WeightedLogJaccard,[0]) phylo1_p
+phylo1_c = pairGroupsToGroups Childs 1 (WeightedLogJaccard,[0.01,0]) phylo1_p
 
 
 phylo1_p :: Phylo
-phylo1_p = pairGroupsToGroups Parents 1 0.01 (WeightedLogJaccard,[0]) phylo1_0_1
+phylo1_p = pairGroupsToGroups Parents 1 (WeightedLogJaccard,[0.01,0]) phylo1_0_1
 
 
 ------------------------------------------------------------------------

src/Gargantext/Viz/Phylo/LevelMaker.hs

@@ -19,15 +19,18 @@ module Gargantext.Viz.Phylo.LevelMaker
 
 import Control.Lens                 hiding (both, Level)
 import Data.List                    ((++), sort, concat, nub, words, zip)
-import Data.Map                     (Map, (!), empty, restrictKeys, filterWithKey, singleton)
+import Data.Map                     (Map, (!), empty, restrictKeys, filterWithKey, singleton, union)
 import Data.Set                     (Set)
 import Data.Text                    (Text, words)
 import Data.Tuple.Extra
 
 import Gargantext.Prelude                   hiding (head)
+import Gargantext.Viz.Phylo.Aggregates.Cluster
 import Gargantext.Viz.Phylo.Aggregates.Cooc
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
+import Gargantext.Viz.Phylo.LinkMaker
+import Gargantext.Viz.Phylo.BranchMaker
 
 import qualified Data.List   as List
 import qualified Data.Map    as Map
@@ -89,7 +92,18 @@ instance PhyloLevelMaker Document
 -- | To transform a Cluster into a Phylogroup 
 clusterToGroup :: PhyloPeriodId -> Level -> Int -> Text -> Cluster -> Map (Date,Date) [Cluster] -> Phylo -> PhyloGroup
 clusterToGroup prd lvl idx lbl groups m p = 
-    PhyloGroup ((prd, lvl), idx) lbl ((sort . nub . concat) $ map getGroupNgrams groups) empty empty [] [] [] (map (\g -> (getGroupId g, 1)) groups)
+    PhyloGroup ((prd, lvl), idx) lbl ngrams empty cooc [] [] [] (map (\g -> (getGroupId g, 1)) groups)
+      where
+        --------------------------------------
+        ngrams :: [Int]
+        ngrams = (sort . nub . concat) $ map getGroupNgrams groups 
+        --------------------------------------
+        cooc :: Map (Int, Int) Double 
+        cooc = filterWithKey (\k _ -> elem (fst k) ngrams && elem (snd k) ngrams) 
+              $ foldl union empty
+              $ map getGroupCooc 
+              $ getGroupsWithFilters 1 prd p        
+        --------------------------------------
 
 
 -- | To transform a Clique into a PhyloGroup
@@ -124,3 +138,21 @@ toPhyloLevel lvl m p = alterPhyloPeriods
                                           let groups = toPhyloGroups lvl pId (m ! pId) m p 
                                           in  phyloLevels ++ [PhyloLevel (pId, lvl) groups]
                                         ) period) p
+
+
+-- | To incrementally add new Levels to a Phylo by making all the linking and aggregation tasks 
+toNthLevel :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> (Proximity,[Double]) -> Phylo -> Phylo
+toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3) p 
+  | lvl >= lvlMax = p
+  | otherwise     = toNthLevel lvlMax (prox,param1) (clus,param2) (prox',param3)
+                  $ pairGroupsToGroups Childs  (lvl + 1) (prox',param3)
+                  $ pairGroupsToGroups Parents (lvl + 1) (prox',param3)
+                  $ setPhyloBranches (lvl + 1)
+                  $ setLevelLinks (lvl, lvl + 1)
+                  $ addPhyloLevel (lvl + 1)
+                    (phyloToClusters lvl (prox,param1) (clus,param2) p) p
+  where
+    --------------------------------------
+    lvl :: Level 
+    lvl = getLastLevel p 
+    --------------------------------------

src/Gargantext/Viz/Phylo/LinkMaker.hs

@@ -18,7 +18,7 @@ module Gargantext.Viz.Phylo.LinkMaker
   where
 
 import Control.Lens                 hiding (both, Level)
-import Data.List                    ((++), sort, concat, nub, words, zip, sortOn, head, null, tail, splitAt, (!!))
+import Data.List                    ((++), sort, concat, nub, words, zip, sortOn, head, null, tail, splitAt, (!!), elem)
 import Data.Map                     (Map)
 import Data.Set                     (Set)
 import Data.Tuple.Extra
@@ -38,11 +38,11 @@ import qualified Data.Maybe as Maybe
 
 
 -- | To choose a LevelLink strategy based an a given Level 
-shouldLink :: (Level,Level) -> [Int] -> [Int] -> Bool
-shouldLink (lvl,lvl') l l'
-  | lvl <= 1  = doesContainsOrd l l'
-  | lvl >  1  = undefined
-  | otherwise = panic ("[ERR][Viz.Phylo.Tools.shouldLink] LevelLink not defined") 
+shouldLink :: (Level,Level) -> PhyloGroup -> PhyloGroup -> Bool
+shouldLink (lvl,lvl') g g'
+  | lvl <= 1  = doesContainsOrd (getGroupNgrams g) (getGroupNgrams g')
+  | lvl >  1  = elem (getGroupId g) (getGroupLevelChildsId g')
+  | otherwise = panic ("[ERR][Viz.Phylo.LinkMaker.shouldLink] Level not defined") 
 
 
 -- | To set the LevelLinks between a given PhyloGroup and a list of childs/parents PhyloGroups
@@ -61,9 +61,7 @@ linkGroupToGroups (lvl,lvl') current targets
     --------------------------------------
     addPointers :: [Pointer] -> [Pointer]
     addPointers lp = lp ++ Maybe.mapMaybe (\target -> 
-                                            if shouldLink (lvl,lvl') 
-                                                          (_phylo_groupNgrams current)
-                                                          (_phylo_groupNgrams target )
+                                            if shouldLink (lvl,lvl') current target
                                             then Just ((getGroupId target),1)
                                             else Nothing) targets 
     --------------------------------------
@@ -89,7 +87,8 @@ setLevelLinks (lvl,lvl') p = alterPhyloGroups (linkGroupsByLevel (lvl,lvl') p) p
 -- | To apply the corresponding proximity function based on a given Proximity
 getProximity :: (Proximity,[Double]) -> PhyloGroup -> PhyloGroup -> (PhyloGroupId, Double)
 getProximity (prox,param) g1 g2 = case prox of 
-  WeightedLogJaccard -> ((getGroupId g2),weightedLogJaccard (param !! 0) (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
+  WeightedLogJaccard -> ((getGroupId g2),weightedLogJaccard (param !! 1) (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
+  Hamming            -> ((getGroupId g2),hamming (getGroupCooc g1) (unifySharedKeys (getGroupCooc g2) (getGroupCooc g1)))
   _                  -> panic ("[ERR][Viz.Phylo.Example.getProximity] Proximity function not defined")
 
 
@@ -123,11 +122,11 @@ getNextPeriods to id l = case to of
 
 
 -- | To find the best set (max = 2) of Childs/Parents candidates based on a given Proximity mesure until a maximum depth (max = Period + 5 units )  
-findBestCandidates :: PairTo -> Int -> Int -> Double -> (Proximity,[Double]) -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
-findBestCandidates to depth max thr (prox,param) group p
+findBestCandidates :: PairTo -> Int -> Int -> (Proximity,[Double]) -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
+findBestCandidates to depth max (prox,param) group p
   | depth > max || null next = [] 
   | (not . null) best = take 2 best
-  | otherwise = findBestCandidates to (depth + 1) max thr (prox,param) group p   
+  | otherwise = findBestCandidates to (depth + 1) max (prox,param) group p   
   where
     --------------------------------------
     next :: [PhyloPeriodId]
@@ -142,7 +141,9 @@ findBestCandidates to depth max thr (prox,param) group p
     best :: [(PhyloGroupId, Double)]
     best = reverse
          $ sortOn snd 
-         $ filter (\(id,score) -> score >= thr) scores
+         $ filter (\(id,score) -> case prox of 
+            WeightedLogJaccard -> score >= (param !! 0)
+            Hamming            -> score <= (param !! 0)) scores
     --------------------------------------
 
 
@@ -160,8 +161,8 @@ makePair to group ids = case to of
 
 
 -- | To pair all the Phylogroups of given PhyloLevel to their best Parents or Childs
-pairGroupsToGroups :: PairTo -> Level -> Double -> (Proximity,[Double]) -> Phylo -> Phylo
-pairGroupsToGroups to lvl thr (prox,param) p = alterPhyloGroups
+pairGroupsToGroups :: PairTo -> Level -> (Proximity,[Double]) -> Phylo -> Phylo
+pairGroupsToGroups to lvl (prox,param) p = alterPhyloGroups
                                     (\groups -> 
                                       map (\group ->
                                             if (getGroupLevel group) == lvl
@@ -169,7 +170,7 @@ pairGroupsToGroups to lvl thr (prox,param) p = alterPhyloGroups
                                               let
                                                 --------------------------------------
                                                 candidates :: [(PhyloGroupId, Double)] 
-                                                candidates = findBestCandidates to 1 5 thr (prox,param) group p
+                                                candidates = findBestCandidates to 1 5 (prox,param) group p
                                                 --------------------------------------
                                               in 
                                                 makePair to group candidates

src/Gargantext/Viz/Phylo/Metrics/Clustering.hs

@@ -17,11 +17,13 @@ Portability : POSIX
 module Gargantext.Viz.Phylo.Metrics.Clustering
   where
 
-import Data.List        (last,head,union,concat,null,nub,(++),init,tail)
-import Data.Map         (Map,elems,adjust,unionWith,intersectionWith)
+import Data.List        (last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!))
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys)
 import Data.Set         (Set)
 import Data.Tuple       (fst, snd)
 
+import Data.Graph.Clustering.Louvain.CplusPlus
+
 import Gargantext.Prelude             hiding (head)
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
@@ -55,3 +57,21 @@ relatedComp idx curr (nodes,edges) next memo
     nodes' :: [PhyloGroup]
     nodes' = filter (\x -> not $ elem x next') nodes
     --------------------------------------
+
+
+louvain :: (PhyloNodes,PhyloEdges) -> [Cluster]
+louvain (nodes,edges) = undefined 
+
+-- louvain :: (PhyloNodes,PhyloEdges) -> [Cluster]
+-- louvain (nodes,edges) = map (\community -> map (\node -> nodes !! (l_node_id node)) community)
+--                       $ groupBy (l_community_id)
+--                       $ cLouvain 
+--                       $ mapKeys (\(x,y) -> (idx x, idx y)) 
+--                       $ fromList edges
+--   where
+--     -------------------------------------- 
+--     idx :: PhyloGroup -> Int
+--     idx e = case elemIndex e nodes of
+--       Nothing -> panic "[ERR][Gargantext.Viz.Phylo.Metrics.Clustering] a node is missing"
+--       Just i  -> i
+--     --------------------------------------  
\ No newline at end of file

src/Gargantext/Viz/Phylo/Metrics/Proximity.hs

@@ -18,7 +18,7 @@ module Gargantext.Viz.Phylo.Metrics.Proximity
   where
 
 import Data.List        (last,head,union,concat,null)
-import Data.Map         (Map,elems,adjust,unionWith,intersectionWith)
+import Data.Map         (Map,elems,adjust,unionWith,intersectionWith,intersection,size)
 import Data.Set         (Set)
 import Data.Tuple       (fst, snd)
 
@@ -31,7 +31,7 @@ import qualified Data.Map    as Map
 import qualified Data.Set    as Set
 
 
--- | To process the weightedLogJaccard between two PhyloGroups fields
+-- | To process the weightedLogJaccard between two PhyloGroup fields
 weightedLogJaccard :: Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> Double
 weightedLogJaccard s f1 f2
   | null wUnion      = 0
@@ -53,3 +53,13 @@ weightedLogJaccard s f1 f2
     sumLog :: [Double] -> Double
     sumLog l = foldl (\mem x -> mem + log (s + x)) 0 l  
     --------------------------------------  
+
+
+-- | To process the Hamming distance between two PhyloGroup fields 
+hamming :: Map (Int, Int) Double -> Map (Int, Int) Double -> Double
+hamming f1 f2 = fromIntegral $ max ((size inter) - (size f1)) ((size inter) - (size f2))
+  where
+    --------------------------------------
+    inter :: Map (Int, Int) Double
+    inter = intersection f1 f2 
+    --------------------------------------
\ No newline at end of file

src/Gargantext/Viz/Phylo/Tools.hs

@@ -138,6 +138,11 @@ getGroupLevel :: PhyloGroup -> Int
 getGroupLevel = snd . fst . getGroupId
 
 
+-- | To get the PhyloGroups Level Childs Ids of a PhyloGroup
+getGroupLevelChildsId :: PhyloGroup -> [PhyloGroupId]
+getGroupLevelChildsId g = map fst $ _phylo_groupLevelChilds g
+
+
 -- | To get the Ngrams of a PhyloGroup
 getGroupNgrams :: PhyloGroup -> [Int]
 getGroupNgrams =  _phylo_groupNgrams
@@ -212,6 +217,15 @@ getKeyPair (x,y) m = case findPair (x,y) m of
                       --------------------------------------
 
 
+-- | To get the last computed Level in a Phylo
+getLastLevel :: Phylo -> Level 
+getLastLevel p = (last . sort) 
+               $ map (snd . getPhyloLevelId) 
+               $ view ( phylo_periods
+                      .  traverse
+                      . phylo_periodLevels ) p
+
+
 -- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of PhyloEdges 
 getNeighbours :: Bool -> PhyloGroup -> PhyloEdges -> [PhyloGroup]
 getNeighbours directed g e = case directed of 
@@ -226,6 +240,11 @@ getPhyloBranches :: Phylo -> [PhyloBranch]
 getPhyloBranches = _phylo_branches
 
 
+-- | To get the PhylolevelId of a given PhyloLevel
+getPhyloLevelId :: PhyloLevel -> PhyloLevelId
+getPhyloLevelId = _phylo_levelId
+
+
 -- | To get all the Phylolevels of a given PhyloPeriod
 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
 getPhyloLevels = view (phylo_periodLevels)