fix the diagonal issue

bin/gargantext-phylo/Main.hs

@@ -80,6 +80,8 @@ data Conf =
           , timeFrame   :: Int
           , timeTh      :: Double
           , timeSens    :: Double
+          , reBranchThr :: Double
+          , reBranchNth :: Int
           , clusterTh   :: Double
           , clusterSens :: Double
           , phyloLevel  :: Int
@@ -208,7 +210,8 @@ main = do
       let mFis  = DM.fromListWith (++) $ DL.sortOn (fst . fst) $ map (\f -> (getFisPeriod f,[f])) fis    
       
       let query = PhyloQueryBuild (phyloName conf) "" (timeGrain conf) (timeStep conf) 
-                  (Fis $ FisParams True (fisSupport conf) (fisClique conf)) [] [] (WeightedLogJaccard $ WLJParams (timeTh conf) (timeSens conf)) (timeFrame conf) (phyloLevel conf)
+                  (Fis $ FisParams True (fisSupport conf) (fisClique conf)) [] [] (WeightedLogJaccard $ WLJParams (timeTh conf) (timeSens conf)) (timeFrame conf) 
+                  (reBranchThr conf) (reBranchNth conf) (phyloLevel conf)
                   (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams (clusterTh conf) (clusterSens conf))
 
       let queryView = PhyloQueryView (viewLevel conf) Merge False 1 [BranchAge] [SizeBranch $ SBParams (minSizeBranch conf)] [BranchPeakFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True           

src/Gargantext/Viz/Phylo.hs

@@ -349,6 +349,9 @@ data PhyloQueryBuild = PhyloQueryBuild
     , _q_interTemporalMatching :: Proximity
     , _q_interTemporalMatchingFrame :: Int
 
+    , _q_reBranchThr :: Double
+    , _q_reBranchNth :: Int
+
     -- Last level of reconstruction
     , _q_nthLevel   :: Level
     -- Clustering method used from level 1 to nthLevel

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

@@ -51,7 +51,7 @@ graphToClusters clust (nodes,edges) = case clust of
 -- | To transform a list of PhyloGroups into a Graph of Proximity
 groupsToGraph :: Double -> Proximity -> [PhyloGroup] -> ([GroupNode],[GroupEdge])
 groupsToGraph nbDocs prox gs = case prox of 
-      WeightedLogJaccard (WLJParams _ sens) -> (gs, map (\(x,y) -> ((x,y), weightedLogJaccard sens (getGroupCooc x) (getGroupCooc y) nbDocs))
+      WeightedLogJaccard (WLJParams _ sens) -> (gs, map (\(x,y) -> ((x,y), weightedLogJaccard sens nbDocs (getGroupCooc x) (getGroupCooc y) (getGroupNgrams x) (getGroupNgrams y)))
                                                   $ getCandidates gs)
       Hamming (HammingParams _)             -> (gs, map (\(x,y) -> ((x,y), hamming (getGroupCooc x) (getGroupCooc y))) $ getCandidates gs)
       _                                     -> undefined 

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

@@ -17,7 +17,7 @@ Portability : POSIX
 module Gargantext.Viz.Phylo.Aggregates.Cooc
   where
 
-import Data.List                    (union,concat,nub,sort)
+import Data.List                    (union,concat,nub,sort, sortOn)
 import Data.Map                     (Map,elems,adjust,filterWithKey,fromListWith,fromList,restrictKeys)
 import Data.Set                     (Set)
 import Data.Vector                  (Vector)
@@ -27,6 +27,7 @@ import Gargantext.Viz.Phylo.Tools
 import qualified Data.Map    as Map
 import qualified Data.Set    as Set
 
+-- import Debug.Trace (trace)
 
 -- | To transform the Fis into a full coocurency Matrix in a Phylo
 fisToCooc :: Map (Date, Date) [PhyloFis] -> Phylo -> Map (Int, Int) Double
@@ -120,6 +121,13 @@ unionOfCooc :: PhyloGroup -> PhyloGroup -> Phylo -> Map (Int,Int) Double
 unionOfCooc g g' p = sumCooc (groupToCooc g p) (groupToCooc g' p)  
 
 
+-- | To get the nth most occurent elems in a coocurency matrix
+getNthMostOcc :: Int -> Map (Int,Int) Double -> [Int]
+getNthMostOcc nth cooc = (nub . concat)
+                       $ map (\((idx,idx'),_) -> [idx,idx'])
+                       $ take nth
+                       $ reverse 
+                       $ sortOn snd $ Map.toList cooc
 
 
 -- phyloCooc :: Map (Int, Int) Double

src/Gargantext/Viz/Phylo/BranchMaker.hs

@@ -47,20 +47,13 @@ getGroupsNgrams :: [PhyloGroup] -> [Int]
 getGroupsNgrams gs = (sort . nub . concat) $ map getGroupNgrams gs
 
 
-getNthMostOcc :: Int -> Map (Int,Int) Double -> [Int]
-getNthMostOcc nth cooc = (nub . concat)
-                       $ map (\((idx,idx'),_) -> [idx,idx'])
-                       $ take (nth `div` 2)
-                       $ reverse 
-                       $ sortOn snd $ Map.toList cooc
-
-
 -- | Get the Nth most coocurent Ngrams in a list of Groups
 getGroupsPeaks :: [PhyloGroup] -> Int -> Phylo -> [Int]
 getGroupsPeaks gs nth p = getNthMostOcc nth 
                         $ getSubCooc (getGroupsNgrams gs) 
                         $ getCooc (getGroupsPeriods gs) p
 
+
 areDistant :: (Date,Date) -> (Date,Date) -> Int -> Bool
 areDistant prd prd' thr = (((fst prd') - (snd prd)) > thr) || (((fst prd) - (snd prd')) > thr)
 
@@ -107,7 +100,7 @@ makeBranchLinks p prox (id,gs) bs pts
     pts' = concat $ map (\(_id,gs') -> findBestPointer p prox gs gs') candidates
     --------------------------------------
     candidates :: [(PhyloBranchId,[PhyloGroup])]
-    candidates = findSimBranches (getPhyloMatchingFrame p) 0.9 4 p (id,gs) bs 
+    candidates = findSimBranches (getPhyloMatchingFrame p) (getPhyloReBranchThr p) (getPhyloReBranchNth p) p (id,gs) bs
 
  
 

src/Gargantext/Viz/Phylo/Example.hs

@@ -105,7 +105,7 @@ queryEx = "title=Cesar et Cleôpatre"
 
 phyloQueryBuild :: PhyloQueryBuild
 phyloQueryBuild = PhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
-             5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.1 20) 5 2 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.3 0) 
+             5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.1 20) 5 0.5 4 2 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.3 0) 
 
 
 

src/Gargantext/Viz/Phylo/LevelMaker.hs

@@ -128,8 +128,7 @@ cliqueToGroup prd lvl idx lbl fis p =
 
 -- | To transform a list of Ngrams into a PhyloGroup
 ngramsToGroup ::  PhyloPeriodId -> Level -> Int -> Text -> [Ngrams] -> Phylo -> PhyloGroup
-ngramsToGroup prd lvl idx lbl ngrams p =
-    PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInRoots x p) ngrams) empty Nothing
+ngramsToGroup prd lvl idx lbl ngrams p = PhyloGroup ((prd, lvl), idx) lbl (sort $ map (\x -> getIdxInRoots x p) ngrams) empty Nothing
                (getMiniCooc (listToFullCombi $ sort $ map (\x -> getIdxInRoots x p) ngrams) (periodsToYears [prd]) (getPhyloCooc p))
                [] [] [] []
 
@@ -141,7 +140,7 @@ toPhyloLevel lvl m p = alterPhyloPeriods
                                     in  over (phylo_periodLevels)
                                         (\phyloLevels ->
                                           let groups = toPhyloGroups lvl pId (m ! pId) m p
-                                          in  phyloLevels ++ [PhyloLevel (pId, lvl) groups]
+                                          in phyloLevels ++ [PhyloLevel (pId, lvl) groups]
                                         ) period) 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                    ((++), sortOn, null, tail, splitAt, elem, concat, sort, delete, intersect, nub, groupBy)
+import Data.List                    ((++), sortOn, null, tail, splitAt, elem, concat, sort, delete, intersect, nub, groupBy, union)
 import Data.Tuple.Extra
 import Data.Map                     (Map,(!),fromListWith,elems,restrictKeys,unionWith,member)
 import Gargantext.Prelude
@@ -108,9 +108,9 @@ periodsToNbDocs prds phylo = sum $ elems
 
 
 -- | To process a given Proximity
-processProximity :: Proximity -> Map (Int, Int) Double -> Map (Int, Int) Double -> Double -> Double
-processProximity proximity cooc cooc' nbDocs = case proximity of 
-  WeightedLogJaccard (WLJParams _ sens) -> weightedLogJaccard sens cooc cooc' nbDocs
+processProximity :: Proximity -> Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> [Int] -> [Int] -> Double
+processProximity proximity nbDocs cooc cooc' ngrams ngrams' = case proximity of 
+  WeightedLogJaccard (WLJParams _ sens) -> weightedLogJaccard sens nbDocs cooc cooc' ngrams ngrams'
   Hamming (HammingParams _)             -> hamming cooc cooc'
   _                                     -> panic "[ERR][Viz.Phylo.LinkMaker.processProximity] Unknown proximity"
 
@@ -136,17 +136,20 @@ findBestCandidates filiation depth limit proximity periods candidates g1 phylo
                   ) similarities
     --------------------------------------
     similarities :: [(PhyloGroupId, Double)]
-    similarities = concat $ map (\(g2,g3) -> let nbDocs = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
-                                                 cooc2  = getGroupCooc g2
-                                                 cooc3  = getGroupCooc g3
-                                                 score  = processProximity proximity cooc1 (unionWith (+) cooc2 cooc3) nbDocs 
+    similarities = concat $ map (\(g2,g3) -> let nbDocs  = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
+                                                 cooc'   = unionWith (+) (getGroupCooc g2) (getGroupCooc g3)
+                                                 ngrams' = union (getGroupNgrams g2) (getGroupNgrams g3)
+                                                 score   = processProximity proximity nbDocs cooc cooc' ngrams ngrams'
                                              in  nub $ [(getGroupId g2,score),(getGroupId g3,score)]) pairsOfCandidates
     --------------------------------------
     pairsOfCandidates :: [(PhyloGroup,PhyloGroup)]
     pairsOfCandidates = listToFullCombi $ filter (\g -> elem (getGroupPeriod g) nextPeriods) candidates
     --------------------------------------
-    cooc1 :: Map (Int,Int) Double
-    cooc1 = getGroupCooc g1
+    cooc :: Map (Int,Int) Double
+    cooc = getGroupCooc g1
+    --------------------------------------
+    ngrams :: [Int]
+    ngrams = getGroupNgrams g1
     --------------------------------------
     nextPeriods :: [(Date,Date)]
     nextPeriods = take depth periods
@@ -159,23 +162,27 @@ findBestCandidates' proximity candidates g1 phylo = pointers
     --------------------------------------
     pointers :: [(PhyloGroupId, Double)]
     pointers = reverse $ sortOn snd $ filter (\(_,score) -> case proximity of
-                  WeightedLogJaccard (WLJParams thr _)   -> score >= thr
+                  WeightedLogJaccard (WLJParams thr _)   -> score >= (thr - 0.1)
                   Hamming (HammingParams thr)            -> score <= thr
                   _                                      -> panic "[ERR][Viz.Phylo.LinkMaker.findBestCandidates'] Unknown proximity"
                   ) similarities
     --------------------------------------
     similarities :: [(PhyloGroupId, Double)]
-    similarities = concat $ map (\(g2,g3) -> let nbDocs = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
-                                                 cooc2  = getGroupCooc g2
-                                                 cooc3  = getGroupCooc g3
-                                                 score  = processProximity proximity cooc1 (unionWith (+) cooc2 cooc3) nbDocs 
+    similarities = concat $ map (\(g2,g3) -> let nbDocs  = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
+                                                 cooc'   = unionWith (+) (getGroupCooc g2) (getGroupCooc g3)
+                                                 ngrams' = union (getGroupNgrams g2) (getGroupNgrams g3)
+                                                 score   = processProximity proximity nbDocs cooc cooc' ngrams ngrams'
                                              in  nub $ [(getGroupId g2,score),(getGroupId g3,score)]) pairsOfCandidates
     --------------------------------------
     pairsOfCandidates :: [(PhyloGroup,PhyloGroup)]
     pairsOfCandidates = listToFullCombi candidates
     --------------------------------------
-    cooc1 :: Map (Int,Int) Double
-    cooc1 = getGroupCooc g1
+    --------------------------------------
+    cooc :: Map (Int,Int) Double
+    cooc = getGroupCooc g1
+    --------------------------------------
+    ngrams :: [Int]
+    ngrams = getGroupNgrams g1
     --------------------------------------             
 
 

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

@@ -17,8 +17,8 @@ Portability : POSIX
 module Gargantext.Viz.Phylo.Metrics.Proximity
   where
 
-import Data.List        (null)
-import Data.Map         (Map,elems,unionWith,intersectionWith,intersection,size,keys)
+import Data.List          (null,union,intersect)
+import Data.Map           (Map,elems,unionWith,intersectionWith,intersection,size,filterWithKey)
 import Gargantext.Prelude
 -- import Debug.Trace (trace)
 
@@ -29,28 +29,69 @@ sumLog :: Double -> [Double] -> Double
 sumLog s l = foldl (\mem x -> mem + log (s + x)) 0 l  
 
 
+-- -- | To process WeighedLogJaccard distance between to coocurency matrix
+-- weightedLogJaccard :: Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> Double -> Double
+-- weightedLogJaccard sens cooc cooc' nbDocs
+--   | null union'      = 0
+--   | union' == inter' = 1
+--   | sens == 0        = (fromIntegral $ length $ keysInter) / (fromIntegral $ length $ keysUnion)
+--   | sens > 0         = (sumInvLog sens $ elems wInter) / (sumInvLog sens $ elems wUnion)
+--   | otherwise        = (sumLog sens $ elems wInter) / (sumLog sens $ elems wUnion)
+--   where
+--     --------------------------------------
+--     keysInter :: [Int]
+--     keysInter = nub $ concat $ map (\(x,x') -> [x,x']) $ keys inter'
+--     --------------------------------------
+--     keysUnion :: [Int]
+--     keysUnion = nub $ concat $ map (\(x,x') -> [x,x']) $ keys union'
+--     --------------------------------------    
+--     wInter :: Map (Int,Int) Double
+--     wInter = map (/nbDocs) inter'
+--     --------------------------------------
+--     wUnion :: Map (Int,Int) Double
+--     wUnion = map (/nbDocs) union'
+--     --------------------------------------
+--     inter' :: Map (Int, Int) Double
+--     inter' = intersectionWith (+) cooc cooc'
+--     --------------------------------------      
+--     union' :: Map (Int, Int) Double
+--     union' = unionWith (+) cooc cooc'
+--     --------------------------------------
+
+
+-- | To compute a jaccard similarity between two lists
+jaccard :: [Int] -> [Int] -> Double
+jaccard inter' union' = ((fromIntegral . length) $ inter') / ((fromIntegral . length) $ union')
+
+
+-- | To get the diagonal of a matrix
+toDiago :: Map (Int, Int) Double -> [Double]  
+toDiago cooc = elems $ filterWithKey (\(x,x') _ -> x == x') cooc  
+
+
 -- | To process WeighedLogJaccard distance between to coocurency matrix
-weightedLogJaccard :: Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> Double -> Double
-weightedLogJaccard sens cooc cooc' nbDocs
-  | null union'      = 0
-  | union' == inter' = 1
-  | sens == 0        = (fromIntegral $ length $ keys inter') / (fromIntegral $ length $ keys union')
-  | sens > 0         = (sumInvLog sens $ elems wInter) / (sumInvLog sens $ elems wUnion)
-  | otherwise        = (sumLog sens $ elems wInter) / (sumLog sens $ elems wUnion)
+weightedLogJaccard :: Double -> Double -> Map (Int, Int) Double -> Map (Int, Int) Double -> [Int] -> [Int] -> Double
+weightedLogJaccard sens nbDocs cooc cooc' ngrams ngrams' 
+  | null gInter      = 0
+  | gInter == gUnion = 1
+  | sens == 0        = jaccard gInter gUnion
+  | sens > 0         = (sumInvLog sens wInter) / (sumInvLog sens wUnion)
+  | otherwise        = (sumLog sens wInter) / (sumLog sens wUnion)
   where
     --------------------------------------
-    wInter :: Map (Int,Int) Double
-    wInter = map (/nbDocs) inter'
+    gInter :: [Int] 
+    gInter = intersect ngrams ngrams'   
     --------------------------------------
-    wUnion :: Map (Int,Int) Double
-    wUnion = map (/nbDocs) union'
+    gUnion :: [Int] 
+    gUnion = union ngrams ngrams'
     --------------------------------------
-    inter' :: Map (Int, Int) Double
-    inter' = intersectionWith (+) cooc cooc'
-    --------------------------------------      
-    union' :: Map (Int, Int) Double
-    union' = unionWith (+) cooc cooc'
+    wInter :: [Double]
+    wInter = toDiago $ map (/nbDocs) $ intersectionWith (+) cooc cooc'      
     --------------------------------------
+    wUnion :: [Double]
+    wUnion = toDiago $ map (/nbDocs) $ unionWith (+) cooc cooc'
+    --------------------------------------
+
 
 
 -- | To process the Hamming distance between two PhyloGroup fields 

src/Gargantext/Viz/Phylo/Tools.hs

@@ -195,6 +195,12 @@ getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 getPhyloMatchingFrame :: Phylo -> Int
 getPhyloMatchingFrame p = _q_interTemporalMatchingFrame $ _phyloParam_query $ getPhyloParams p
 
+getPhyloReBranchThr :: Phylo -> Double
+getPhyloReBranchThr p = _q_reBranchThr $ _phyloParam_query $ getPhyloParams p
+
+getPhyloReBranchNth :: Phylo -> Int
+getPhyloReBranchNth p = _q_reBranchNth $ _phyloParam_query $ getPhyloParams p
+
 getPhyloFis :: Phylo -> Map (Date,Date) [PhyloFis]
 getPhyloFis = _phylo_fis
 
@@ -471,7 +477,8 @@ initPhyloPeriod id l = PhyloPeriod id l
 
 -- | To transform a list of periods into a set of Dates
 periodsToYears :: [(Date,Date)] -> Set Date
-periodsToYears periods = (Set.fromList . sort . concat) [[d,d'] | (d,d') <- periods]
+periodsToYears periods = (Set.fromList . sort . concat)
+                       $ map (\(d,d') -> [d..d']) periods
 
 
 --------------------
@@ -793,11 +800,10 @@ initWeightedLogJaccard (def 0 -> thr) (def 0.01 -> sens) = WLJParams thr sens
 
 
 -- | To initialize a PhyloQueryBuild from given and default parameters
-initPhyloQueryBuild :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Int -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
+initPhyloQueryBuild :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Int -> Maybe Double -> Maybe Int -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
 initPhyloQueryBuild name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis -> cluster) (def [] -> metrics) (def [] -> filters)
-  (def defaultWeightedLogJaccard -> matching') (def 5 -> frame) (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
-    PhyloQueryBuild name desc grain steps cluster metrics filters matching' frame nthLevel nthCluster
-
+  (def defaultWeightedLogJaccard -> matching') (def 5 -> frame) (def 0.5 -> reBranchThr) (def 4 -> reBranchNth) (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
+    PhyloQueryBuild name desc grain steps cluster metrics filters matching' frame reBranchThr reBranchNth nthLevel nthCluster
 
 
 -- | To initialize a PhyloQueryView default parameters
@@ -850,7 +856,7 @@ defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing N
 
 defaultQueryBuild :: PhyloQueryBuild
 defaultQueryBuild = initPhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
-                              Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+                              Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 
 defaultQueryView :: PhyloQueryView
 defaultQueryView = initPhyloQueryView Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

src/Gargantext/Viz/Phylo/View/Export.hs

@@ -157,7 +157,9 @@ setDotNode pn = node (toNodeDotId $ pn ^. pn_id)
 
 -- | To set an Edge
 setDotEdge :: PhyloEdge -> Dot DotId
-setDotEdge pe = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Black]]
+setDotEdge pe 
+  | pe ^. pe_weight == 100 = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Red]]
+  | otherwise = edge (toNodeDotId $ pe ^. pe_source) (toNodeDotId $ pe ^. pe_target)  [Width 2, Color [toWColor Black]]
 
 
 -- | To set a Period Edge

src/Gargantext/Viz/Phylo/View/Taggers.hs

@@ -26,8 +26,9 @@ import Data.Map         (Map)
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
-import Gargantext.Viz.Phylo.Aggregates.Cooc
+import Gargantext.Viz.Phylo.BranchMaker
 import qualified Data.Map    as Map
+-- import Debug.Trace (trace)
 
 
 -- | To get the nth most frequent Ngrams in a list of PhyloGroups
@@ -48,14 +49,15 @@ freqToLabel thr ngs l = ngramsToLabel ngs $ mostFreqNgrams thr l
 
 
 -- | To get the (nth `div` 2) most cooccuring Ngrams in a PhyloGroup
-mostOccNgrams :: Int -> Phylo -> PhyloGroup -> [Int]
-mostOccNgrams thr p g = (nub . concat )
-                          $ map (\((f,s),_d) -> [f,s])
-                          $ take (thr `div` 2)
-                          $ reverse $ sortOn snd $ Map.toList cooc
+mostOccNgrams :: Int -> PhyloGroup -> [Int]
+mostOccNgrams nth g = (nub . concat)
+                    $ map (\((f,s),_d) -> [f,s])
+                    $ take nth
+                    $ reverse $ sortOn snd
+                    $ Map.toList cooc
   where
     cooc :: Map (Int, Int) Double
-    cooc = getSubCooc (getGroupNgrams g) $ getCooc [getGroupPeriod g] p
+    cooc = getGroupCooc g
 
 
 -- | To alter the peak of a PhyloBranch
@@ -74,13 +76,18 @@ branchPeakFreq v thr p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v
                                               $ getGroupsFromNodes ns p))
                         $ getNodesByBranches v
 
+branchPeakCooc :: PhyloView -> Int -> Phylo -> PhyloView
+branchPeakCooc v nth p = foldl (\v' (id,lbl) -> alterBranchPeak (id,lbl) v') v
+                       $ map (\(id,ns) -> (id, ngramsToLabel (getFoundationsRoots p) (getGroupsPeaks (getGroupsFromNodes ns p) nth p) ) ) 
+                       $ getNodesByBranches v
+
 
 -- | To set the label of a PhyloNode as the nth most coocurent terms of its PhyloNodes
 nodeLabelCooc :: PhyloView -> Int -> Phylo -> PhyloView
 nodeLabelCooc v thr p = over (pv_nodes
                              . traverse)
                              (\n -> let lbl = ngramsToLabel (getFoundationsRoots p)
-                                            $ mostOccNgrams thr p
+                                            $ mostOccNgrams thr
                                             $ head' "nodeLabelCooc" $ getGroupsFromIds [getNodeId n] p
                                     in n & pn_label .~ lbl) v
 
@@ -89,6 +96,7 @@ nodeLabelCooc v thr p = over (pv_nodes
 processTaggers :: [Tagger] -> Phylo -> PhyloView -> PhyloView
 processTaggers ts p v = foldl (\v' t -> case t of
                                         BranchPeakFreq -> branchPeakFreq v' 2 p
+                                        -- BranchPeakFreq -> branchPeakCooc v' 3 p
                                         GroupLabelCooc -> nodeLabelCooc  v' 2 p
                                         _              -> panic "[ERR][Viz.Phylo.View.Taggers.processTaggers] tagger not found") v ts