add the reBranch

bin/gargantext-phylo/Main.hs

@@ -78,6 +78,7 @@ data Conf =
           , timeGrain   :: Int
           , timeStep    :: Int
           , timeFrame   :: Int
+          , timeFrameTh :: Double          
           , timeTh      :: Double
           , timeSens    :: Double
           , reBranchThr :: Double
@@ -210,7 +211,7 @@ 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) 
+                  (Fis $ FisParams True (fisSupport conf) (fisClique conf)) [] [] (WeightedLogJaccard $ WLJParams (timeTh conf) (timeSens conf)) (timeFrame conf) (timeFrameTh conf) 
                   (reBranchThr conf) (reBranchNth conf) (phyloLevel conf)
                   (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams (clusterTh conf) (clusterSens conf))
 

src/Gargantext/Viz/Phylo.hs

@@ -352,6 +352,7 @@ data PhyloQueryBuild = PhyloQueryBuild
     -- Inter-temporal matching method of the Phylo
     , _q_interTemporalMatching :: Proximity
     , _q_interTemporalMatchingFrame :: Int
+    , _q_interTemporalMatchingFrameTh :: Double
 
     , _q_reBranchThr :: Double
     , _q_reBranchNth :: Int

src/Gargantext/Viz/Phylo/BranchMaker.hs

@@ -19,8 +19,8 @@ module Gargantext.Viz.Phylo.BranchMaker
 
 import Control.Parallel.Strategies
 import Control.Lens     hiding (both, Level)
-import Data.List        (concat,nub,(++),tail,sortOn,take,reverse,sort,null,intersect,union)
-import Data.Map         (Map)
+import Data.List        (concat,nub,(++),tail,sortOn,take,reverse,sort,null,intersect,union,delete)
+import Data.Map         (Map,(!), fromListWith, elems)
 import Data.Tuple       (fst, snd)
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo
@@ -48,13 +48,6 @@ getGroupsNgrams :: [PhyloGroup] -> [Int]
 getGroupsNgrams gs = (sort . nub . concat) $ map getGroupNgrams gs
 
 
--- | 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)
 
@@ -65,61 +58,67 @@ areTwinPeaks thr ns ns' = ( ((fromIntegral . length) $ intersect ns ns')
                           / ((fromIntegral . length) $ union ns ns')) >= thr 
 
 
-findSimBranches :: Int -> Double -> Int -> Phylo -> (PhyloBranchId,[PhyloGroup]) -> [(PhyloBranchId,[PhyloGroup])] -> [(PhyloBranchId,[PhyloGroup])]
-findSimBranches frame thr nth p (id,gs) bs 
-  = filter (\(_  ,gs') -> areTwinPeaks thr pks (getGroupsPeaks gs' nth p))
-  $ filter (\(_  ,gs') -> (not . null) $ intersect ns (getGroupsNgrams gs'))
-  $ filter (\(_  ,gs') -> areDistant prd (getFramedPeriod gs') frame)
-  $ filter (\(id',_  ) -> id /= id') bs
-  where 
-    --------------------------------------
-    prd :: (Date,Date)
-    prd = getFramedPeriod gs
-    --------------------------------------
-    ns :: [Int]
-    ns = getGroupsNgrams gs
-    --------------------------------------
-    pks :: [Int]
-    pks = getGroupsPeaks gs nth p
-    --------------------------------------
-
-
-findBestPointer :: Phylo -> Proximity -> [PhyloGroup] -> [PhyloGroup] -> [(PhyloGroupId,Pointer)]
-findBestPointer p prox gs gs' =
-  let candidates  = map (\g -> let pts = findBestCandidates' prox gs' g p
-                               in map (\pt -> (getGroupId g,pt)) pts) gs
-      candidates' = candidates `using` parList rdeepseq
-  in take 1 $ reverse $ sortOn (snd . snd) $ concat candidates' 
-
+-- | Get the framing period of a branch ([[PhyloGroup]])
+getBranchPeriod :: [PhyloGroup] -> (Date,Date) 
+getBranchPeriod gs =
+  let dates = sort $ foldl (\mem g -> mem ++ [fst $ getGroupPeriod g, snd $ getGroupPeriod g]) [] gs
+  in  (head' "getBranchPeriod" dates, last' "getBranchPeriod" dates)
 
-makeBranchLinks :: Phylo -> Proximity -> (PhyloBranchId,[PhyloGroup]) -> [(PhyloBranchId,[PhyloGroup])] -> [(PhyloGroupId,Pointer)] -> [(PhyloGroupId,Pointer)]
-makeBranchLinks p prox (id,gs) bs pts
-  | null bs   = pts
-  | otherwise = makeBranchLinks p prox (head' "makeLink" bs) (tail bs) (pts ++ pts')
-  where
-    --------------------------------------
-    pts' :: [(PhyloGroupId,Pointer)]
-    pts' = concat $ map (\(_id,gs') -> findBestPointer p prox gs gs') candidates
-    --------------------------------------
-    candidates :: [(PhyloBranchId,[PhyloGroup])]
-    candidates = findSimBranches (getPhyloMatchingFrame p) (getPhyloReBranchThr p) (getPhyloReBranchNth p) p (id,gs) bs
 
+-- | 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
 
 
-linkPhyloBranches :: Level -> Proximity -> Phylo -> Phylo
-linkPhyloBranches lvl prox p = setPhyloBranches lvl
-                             $ updateGroups Descendant lvl pointers p
+-- | Reduce a list of branches ([[Phylogroup]]) into possible candidates for rebranching
+filterSimBranches :: [PhyloGroup] -> Phylo -> [[PhyloGroup]] -> [[PhyloGroup]]
+filterSimBranches gs p branches = filter (\gs' -> (areTwinPeaks (getPhyloReBranchThr p)
+                                                                (getGroupsPeaks gs  (getPhyloReBranchNth p) p)
+                                                                (getGroupsPeaks gs' (getPhyloReBranchNth p)  p))
+                                               && ((not . null) $ intersect (map getGroupNgrams gs') (map getGroupNgrams gs))
+                                               && (areDistant (getBranchPeriod gs) (getBranchPeriod gs') (getPhyloMatchingFrame p))
+                                         ) branches 
+
+
+-- | Try to connect a focused branch to other candidate branches by finding the best pointers 
+reBranch :: Phylo -> [PhyloGroup] -> [[PhyloGroup]] -> [(PhyloGroupId,Pointer)]
+reBranch p branch candidates =
+  let newLinks  = map (\branch' ->
+        let pointers = map (\g -> 
+              -- define pairs of candidates groups
+              let pairs = listToPairs
+                        $ filter (\g' -> (not . null) $ intersect (getGroupNgrams g') (getGroupNgrams g)) branch'
+              -- process the matching between the pairs and the current group
+              in  foldl' (\mem (g2,g3) -> let s = 0.1 + matchWithPairs g (g2,g3) p
+                                          in if (g2 == g3)
+                                             then mem ++ [(getGroupId g,(getGroupId g2,s))]
+                                             else mem ++ [(getGroupId g,(getGroupId g2,s)),(getGroupId g,(getGroupId g3,s))]) [] pairs
+              ) branch
+            pointers' = pointers `using` parList rdeepseq
+        --  keep the best pointer between the focused branch and the current candidates 
+        in head' "reBranch" $ reverse $ sortOn (snd . snd) 
+         $ filter (\(_,(_,s)) -> filterProximity s $ getPhyloProximity p) $ concat pointers'
+        ) candidates
+      newLinks' = newLinks `using` parList rdeepseq
+  in  newLinks'
+
+
+reLinkPhyloBranches :: Level -> Phylo -> Phylo
+reLinkPhyloBranches lvl p = 
+  let pointers = Map.fromList $ map (\(_id,(_id',_s)) -> (_id,[(_id',100)])) $ fst
+               $ foldl' (\(pts,branches') gs -> (pts ++ (reBranch p gs (filterSimBranches gs p branches')), delete gs branches')) 
+                        ([],branches) branches
+  in setPhyloBranches lvl $ updateGroups Descendant lvl pointers p
   where 
-    --------------------------------------
-    pointers :: Map PhyloGroupId [Pointer]
-    pointers = Map.fromList $ map (\(_id,(_id',_w)) -> (_id,[(_id',100)]))
-                            $ makeBranchLinks p prox (head' "makeLink" branches) (tail branches) []
-    --------------------------------------
-    branches :: [(PhyloBranchId,[PhyloGroup])]
-    branches = sortOn (\(_id,gs) -> fst $ getFramedPeriod gs) $ getGroupsByBranches p
-    -------------------------------------- 
-
-
+    branches :: [[PhyloGroup]]
+    branches = elems 
+             $ fromListWith (++) 
+             $ foldl' (\mem g -> case getGroupBranchId g of
+                                 Nothing -> mem
+                                 Just i  -> mem ++ [(i,[g])] )
+               [] $ getGroupsWithLevel lvl p
 
 
 ------------------
@@ -128,22 +127,25 @@ linkPhyloBranches lvl prox p = setPhyloBranches lvl
 
 
 -- | To transform a PhyloGraph into a list of PhyloBranches by using the relatedComp clustering
-graphToBranches :: [PhyloGroup] -> Phylo -> [(Int,PhyloGroupId)]
-graphToBranches groups p = concat
-                         $ map (\(idx,gs) -> map (\g -> (idx,getGroupId g)) gs)
+graphToBranches :: [PhyloGroup] -> Map PhyloGroupId Int
+graphToBranches groups  = Map.fromList
+                         $ concat
+                         $ map (\(idx,gIds) -> map (\id -> (id,idx)) gIds)
                          $ zip [1..]
                          $ relatedComp
-                         $ map (\g -> nub $ [g] ++ (getGroupParents g p) ++ (getGroupChilds g p)) groups
+                         $ map (\g -> [getGroupId g] ++ (getGroupPeriodParentsId g) ++ (getGroupPeriodChildsId g)) groups
 
 
 -- | To set all the PhyloBranches for a given Level in a Phylo
 setPhyloBranches :: Level -> Phylo -> Phylo
 setPhyloBranches lvl p = alterGroupWithLevel (\g -> 
-  let bIdx = (fst $ head' "branchMaker" 
-                  $ filter (\b -> snd b == getGroupId g) branches)
+  let bIdx = branches ! (getGroupId g)
   in  over (phylo_groupBranchId) (\_ -> Just (lvl,bIdx)) g) lvl p
   where 
     --------------------------------------
-    branches :: [(Int,PhyloGroupId)]
-    branches = graphToBranches (getGroupsWithLevel lvl p) p
+    branches :: Map PhyloGroupId Int
+    branches = graphToBranches (getGroupsWithLevel lvl p)
     --------------------------------------
+
+
+-- trace' bs = trace bs
\ No newline at end of file

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.6 20) 5 0.5 4 2 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.4 0) 
+             5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.6 20) 5 0.8 0.5 4 2 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.4 0) 
 
 
 

src/Gargantext/Viz/Phylo/LevelMaker.hs

@@ -162,6 +162,7 @@ toNthLevel lvlMax prox clus p
   | otherwise     = toNthLevel lvlMax prox clus
                   $ traceBranches (lvl + 1)
                   $ setPhyloBranches (lvl + 1)
+                  $ traceTranspose (lvl + 1)
                   $ transposePeriodLinks (lvl + 1)
                   $ tracePhyloN (lvl + 1)
                   $ setLevelLinks (lvl, lvl + 1)
@@ -181,7 +182,7 @@ toNthLevel lvlMax prox clus p
 toPhylo1 :: Cluster -> Proximity -> Map (Date, Date) [Document] -> Phylo -> Phylo
 toPhylo1 clus prox d p = case clus of
   Fis (FisParams k s t) -> traceReBranches 1 
-                       -- $ linkPhyloBranches 1 prox
+                       -- $ reLinkPhyloBranches 1 
                        $ traceBranches 1 
                        $ setPhyloBranches 1
                        $ traceTempoMatching Descendant 1
@@ -310,6 +311,12 @@ tracePhyloN lvl p = trace ("\n---------------\n--| Phylo " <> show (lvl) <> " |-
                       <> show (length $ getGroupsWithLevel lvl p) <> " groups created \n") p
 
 
+traceTranspose :: Level -> Phylo -> Phylo
+traceTranspose lvl p = trace ("----\nTranspose "
+                      <> show (length $ getGroupsWithLevel lvl p) <> " groups in Phylo "
+                      <> show (lvl) <> "\n") p
+
+
 tracePhyloBase :: Phylo -> Phylo
 tracePhyloBase p = trace ( "\n-------------\n--| Phylo |--\n-------------\n\n" 
                         <> show (length $ _phylo_periods p) <> " periods from " 

src/Gargantext/Viz/Phylo/LinkMaker.hs

@@ -103,7 +103,6 @@ filterProximity score prox =  case prox of
   _                                      -> panic "[ERR][Viz.Phylo.LinkMaker.filterProximity] Unknown proximity"
 
 
-
 makePairs :: [(Date,Date)] -> PhyloGroup -> Phylo -> [(PhyloGroup,PhyloGroup)]
 makePairs prds g p = filter (\pair -> ((last' "makePairs" prds) == (getGroupPeriod $ fst pair))
                                     || ((last' "makePairs" prds) == (getGroupPeriod $ snd pair)))
@@ -111,47 +110,9 @@ makePairs prds g p = filter (\pair -> ((last' "makePairs" prds) == (getGroupPeri
                     $ filter (\g' -> (elem (getGroupPeriod g') prds)
                                  && ((not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g'))
                                  && (((last' "makePairs" prds) == (getGroupPeriod g))
-                                     ||((matchWithPairs g (g,g') p) >= (getThreshold $ getPhyloProximity p))))
+                                     ||((matchWithPairs g (g,g') p) >= (getPhyloMatchingFrameTh p))))
                     $ getGroupsWithLevel (getGroupLevel g) p 
 
-
-
--- | Find the best candidates to be time-linked with a group g1 (recursively until the limit of periods is reached)
--- | 1) find the next periods and get the mini cooc matrix of g1
--- | 2) build the pairs of candidates (single groups or tuples)
--- | 3) process the proximity mesure and select the best ones to create the pointers (ie: all the max)
-findBestCandidates :: Filiation -> Int -> Int -> Proximity -> [(Date,Date)] -> PhyloGroup -> Phylo -> ([Pointer],[Double])
-findBestCandidates filiation depth limit proximity periods g1 phylo
-  | depth > limit || null nextPeriods = ([],[])
-  | (not . null) pointers             = (head' "findBestCandidates" $ groupBy (\x y -> snd x == snd y) pointers
-                                        ,map snd similarities)
-  | otherwise                         = findBestCandidates filiation (depth + 1) limit proximity periods g1 phylo
-  where  
-    --------------------------------------
-    pointers :: [(PhyloGroupId, Double)]
-    pointers = reverse $ sortOn snd $ filter (\(_,score) -> filterProximity score proximity) similarities
-    --------------------------------------
-    similarities :: [(PhyloGroupId, Double)]
-    similarities = concat $ map (\(g2,g3) -> 
-      let nbDocs  = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] phylo
-          cooc'   = if (g2 == g3)
-                      then getGroupCooc g2
-                      else unionWith (+) (getGroupCooc g2) (getGroupCooc g3)
-          ngrams' = if (g2 == g3)
-                      then getGroupNgrams g2
-                      else union (getGroupNgrams g2) (getGroupNgrams g3)
-          score   = processProximity proximity nbDocs (getGroupCooc g1) cooc' (getGroupNgrams g1) ngrams'
-      in  if (g2 == g3)
-            then [(getGroupId g2,score)] 
-            else [(getGroupId g2,score),(getGroupId g3,score)] ) pairsOfCandidates
-    --------------------------------------
-    pairsOfCandidates :: [(PhyloGroup,PhyloGroup)]
-    pairsOfCandidates = makePairs nextPeriods g1 phylo
-    --------------------------------------
-    nextPeriods :: [(Date,Date)]
-    nextPeriods = take depth periods
-    --------------------------------------
-
 matchWithPairs :: PhyloGroup -> (PhyloGroup,PhyloGroup) -> Phylo -> Double
 matchWithPairs g1 (g2,g3) p = 
   let nbDocs = periodsToNbDocs [(getGroupPeriod g1),(getGroupPeriod g2),(getGroupPeriod g3)] p
@@ -192,38 +153,6 @@ phyloGroupMatching periods g p = case pointers of
     --------------------------------------           
 
 
-
-
-findBestCandidates' :: Proximity -> [PhyloGroup] -> PhyloGroup -> Phylo -> [Pointer]
-findBestCandidates' proximity candidates g1 phylo = pointers
-  where  
-    --------------------------------------
-    pointers :: [(PhyloGroupId, Double)]
-    pointers = reverse $ sortOn snd $ filter (\(_,score) -> case proximity of
-                  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
-                                                 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
-    --------------------------------------
-    --------------------------------------
-    cooc :: Map (Int,Int) Double
-    cooc = getGroupCooc g1
-    --------------------------------------
-    ngrams :: [Int]
-    ngrams = getGroupNgrams g1
-    --------------------------------------             
-
-
 -- | To add some Pointer to a PhyloGroup
 addPointers' :: Filiation -> [Pointer] -> PhyloGroup -> PhyloGroup
 addPointers' fil pts g = g & case fil of 
@@ -277,12 +206,6 @@ toBranches mem gs
 interTempoMatching :: Filiation -> Level -> Proximity -> Phylo -> Phylo
 interTempoMatching fil lvl _ p = updateGroups fil lvl (Map.fromList pointers) p
   where
-    --------------------------------------
-    -- debug :: [Pointers]
-    -- debug = concat $ map (snd) pointers     
-    --------------------------------------
-    -- pointersMap :: Map PhyloGroupId [Pointer]
-    -- pointersMap = Map.fromList $ map (\(id,x) -> (id,fst x)) pointers
     --------------------------------------
     pointers :: [(PhyloGroupId,[Pointer])]
     pointers = 
@@ -299,33 +222,41 @@ interTempoMatching fil lvl _ p = updateGroups fil lvl (Map.fromList pointers) p
 ------------------------------------------------------------------------
 -- | Make links from Period to Period after level 1
 
-toLevelUp :: [Pointer] -> Phylo -> [Pointer]
-toLevelUp lst p = Map.toList 
-                $ map (\ws -> maximum ws)
-                $ fromListWith (++) [(id, [w]) | (id, w) <- 
-                  let pointers  = map (\(id,v) -> (getGroupLevelParentId $ getGroupFromId id p, v)) lst
-                      pointers' = pointers `using` parList rdeepseq
-                  in  pointers' ]
-
-
 -- | Transpose the parent/child pointers from one level to another
 transposePeriodLinks :: Level -> Phylo -> Phylo
-transposePeriodLinks lvl p = alterGroupWithLevel
-  (\g ->
+transposePeriodLinks lvl p = alterPhyloGroups
+  (\gs -> if ((not . null) gs) && (elem lvl $ map getGroupLevel gs)  
+              then 
+                let groups  = map (\g -> g & phylo_groupPeriodParents .~ (trackPointers (reduceGroups g lvlGroups) 
+                                                                                      $ g ^. phylo_groupPeriodParents)
+                                           & phylo_groupPeriodChilds  .~ (trackPointers (reduceGroups g lvlGroups)
+                                                                                      $ g ^. phylo_groupPeriodChilds )) gs
+                    groups' = groups `using` parList rdeepseq
+                    in groups'
+              else gs
+  ) p
+  where
+    --------------------------------------
+    -- | find an other way to find the group from the id
+    trackPointers :: Map PhyloGroupId PhyloGroup -> [Pointer] -> [Pointer]
+    trackPointers m pts = Map.toList
+                        $ fromListWith (\w w' -> max w w')
+                        $ map (\(id,_w) -> (getGroupLevelParentId $ m ! id,_w)) pts
     --------------------------------------                  
-    let ascLink = toLevelUp (getGroupPeriodParents g) p 
-        desLink = toLevelUp (getGroupPeriodChilds  g) p
+    reduceGroups :: PhyloGroup -> [PhyloGroup] -> Map PhyloGroupId PhyloGroup
+    reduceGroups g gs = Map.fromList
+                     $ map (\g' -> (getGroupId g',g')) 
+                     $ filter (\g' -> ((not . null) $ intersect (getGroupNgrams g) (getGroupNgrams g'))) gs 
     --------------------------------------
-    in g & phylo_groupPeriodParents .~ ascLink
-         & phylo_groupPeriodChilds  .~ desLink
+    lvlGroups :: [PhyloGroup]
+    lvlGroups = getGroupsWithLevel (lvl - 1) p
     --------------------------------------
-  ) lvl p 
+
 
 ----------------
 -- | Tracer | --
 ----------------
 
-
 traceMatching :: Filiation -> Level -> Double -> [Double] -> Phylo -> Phylo
 traceMatching fil lvl thr lst p = trace ( "----\n" <> show (fil) <> " unfiltered temporal Matching in Phylo" <> show (lvl) <> " :\n"
                                       <> "count : " <> show (length lst) <> " potential pointers (" <> show (length $ filter (>= thr) lst) <> " >= " <> show (thr) <> ")\n"

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

@@ -22,8 +22,11 @@ import Data.List        (concat,null,nub,(++),elemIndex,groupBy,(!!), (\\), unio
 import Data.Map         (fromList,mapKeys)
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo
+-- import Gargantext.Viz.Phylo.Tools
 
-relatedComp :: [[PhyloGroup]] -> [[PhyloGroup]]
+-- import Debug.Trace (trace)
+
+relatedComp :: Eq a => [[a]] -> [[a]]
 relatedComp graphs = foldl' (\mem groups -> 
   if (null mem)
   then mem ++ [groups]

src/Gargantext/Viz/Phylo/Tools.hs

@@ -202,6 +202,9 @@ getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
 getPhyloMatchingFrame :: Phylo -> Int
 getPhyloMatchingFrame p = _q_interTemporalMatchingFrame $ _phyloParam_query $ getPhyloParams p
 
+getPhyloMatchingFrameTh :: Phylo -> Double
+getPhyloMatchingFrameTh p = _q_interTemporalMatchingFrameTh $ _phyloParam_query $ getPhyloParams p
+
 getPhyloProximity :: Phylo -> Proximity
 getPhyloProximity p = _q_interTemporalMatching $ _phyloParam_query $ getPhyloParams p
 
@@ -392,13 +395,19 @@ getGroups = view ( phylo_periods
                  )
 
 
--- | To get all PhyloGroups matching a list of PhyloGroupIds in a Phylo
-getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
-getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
+-- | To get all PhyloGroups matching a list of PhyloGoupIds in a Phylo
+-- getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
+-- getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
 
--- | To get a PhyloGroup matching a PhyloGroupId in a Phylo
 getGroupFromId :: PhyloGroupId -> Phylo -> PhyloGroup
-getGroupFromId id p = (head' "getGroupFromId") $ getGroupsFromIds [id] p
+getGroupFromId id p = 
+  let groups = Map.fromList $ map (\g -> (getGroupId g, g)) $ getGroups p
+  in  groups ! id 
+
+getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
+getGroupsFromIds ids p =
+  let groups = Map.fromList $ map (\g -> (getGroupId g, g)) $ getGroups p
+  in  elems $ restrictKeys groups (Set.fromList ids)
 
 
 -- | To get the corresponding list of PhyloGroups from a list of PhyloNodes
@@ -810,10 +819,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 Double -> 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 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 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
+  (def defaultWeightedLogJaccard -> matching') (def 5 -> frame) (def 0.8 -> frameThr) (def 0.5 -> reBranchThr) (def 4 -> reBranchNth) (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
+    PhyloQueryBuild name desc grain steps cluster metrics filters matching' frame frameThr reBranchThr reBranchNth nthLevel nthCluster
 
 
 -- | To initialize a PhyloQueryView default parameters
@@ -866,7 +875,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 Nothing Nothing Nothing
 
 defaultQueryView :: PhyloQueryView
 defaultQueryView = initPhyloQueryView Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing