Add the branch detection with a bugg

src/Gargantext/Viz/Phylo.hs

@@ -72,6 +72,7 @@ data Phylo =
      Phylo { _phylo_duration :: (Start, End)
            , _phylo_ngrams   :: PhyloNgrams
            , _phylo_periods  :: [PhyloPeriod]
+           , _phylo_branches :: [PhyloBranch]
            }
            deriving (Generic, Show)
 
@@ -94,7 +95,6 @@ data PhyloPeriod =
                  } 
                  deriving (Generic, Show)
 
-type PhyloPeriodId = (Start, End)
 
 -- | PhyloLevel : levels of phylomemy on level axis
 -- Levels description:
@@ -108,7 +108,6 @@ data PhyloLevel =
                 }
                 deriving (Generic, Show)
 
-type PhyloLevelId = (PhyloPeriodId, Int)
 
 -- | PhyloGroup : group of ngrams at each level and step
 -- Label : maybe has a label as text
@@ -122,7 +121,7 @@ data PhyloGroup =
                 , _phylo_groupLabel         :: Text
                 , _phylo_groupNgrams        :: [Int]
                 , _phylo_groupQuality       :: Map Text Double
-                , _phylo_groupCooc          :: Map (Int, Int) Double 
+                , _phylo_groupCooc          :: Map (Int, Int) Double
                 
                 , _phylo_groupPeriodParents :: [Pointer]
                 , _phylo_groupPeriodChilds  :: [Pointer]
@@ -132,11 +131,21 @@ data PhyloGroup =
                 }
                 deriving (Generic, Show, Eq)
 
-type PhyloGroupId = (PhyloLevelId, Int)
-type Pointer      = (PhyloGroupId, Weight)
-type Weight       = Double
+data PhyloBranch =
+     PhyloBranch { _phylo_branchId     :: (Int,Int)
+                 , _phylo_branchLabel  :: Text
+                 , _phylo_branchGroups :: [PhyloGroupId] 
+                 }
+                 deriving (Generic, Show)                
+
+type PhyloPeriodId = (Start, End)
+type PhyloLevelId  = (PhyloPeriodId, Int)
+type PhyloGroupId  = (PhyloLevelId, Int)
 
+type Pointer       = (PhyloGroupId, Weight)
+type Weight        = Double
 
+type PhyloBranchId = (Int, Int)
 
 
 -- | Ngrams : a contiguous sequence of n terms
@@ -162,7 +171,7 @@ data LevelLabel = Level_m1 | Level_0 | Level_1 | Level_mN | Level_N | Level_pN
 data Level = 
      Level { _levelLabel :: LevelLabel
            , _levelValue :: Int 
-           } deriving (Show)
+           } deriving (Show, Eq)
 
 data LevelLink =
      LevelLink { _levelFrom :: Level
@@ -195,12 +204,14 @@ makeLenses ''PhyloLevel
 makeLenses ''PhyloPeriod
 makeLenses ''Level
 makeLenses ''LevelLink
+makeLenses ''PhyloBranch
 
 -- | JSON instances
-$(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       )
-$(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
+$(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       ) 
+$(deriveJSON (unPrefix "_phylo_period" ) 'PhyloPeriod  )
 $(deriveJSON (unPrefix "_phylo_level"  ) ''PhyloLevel  )
 $(deriveJSON (unPrefix "_phylo_group"  ) ''PhyloGroup  )
+$(deriveJSON (unPrefix "_phylo_branch" ) ''PhyloBranch )
 -- 
 $(deriveJSON (unPrefix "_software_"    ) ''Software    )
 $(deriveJSON (unPrefix "_phyloParam_"  ) ''PhyloParam  )

src/Gargantext/Viz/Phylo/Example.hs

@@ -30,7 +30,7 @@ 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)
+import Data.List        (concat, union, intersect, tails, tail, head, last, null, zip, sort, length, any, (++), (!!), nub, sortOn, reverse, splitAt, take, delete)
 import Data.Map         (Map, elems, member, adjust, singleton, empty, (!), keys, restrictKeys, mapWithKey, filterWithKey, mapKeys, intersectionWith, unionWith)
 import Data.Semigroup   (Semigroup)
 import Data.Set         (Set)
@@ -55,13 +55,63 @@ import qualified Data.Vector as Vector
 
 
 ------------------------------------------------------------------------
--- | STEP 13 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo   
+-- | STEP 14 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo   
 
 
 ------------------------------------------------------------------------
--- | STEP 12 | -- Cluster the Fis
+-- | STEP 13 | -- Cluster the Fis
 
 
+------------------------------------------------------------------------
+-- | STEP 12 | -- Find the Branches
+
+initPhyloBranch :: (Int,Int) -> Text -> [PhyloGroupId] -> PhyloBranch
+initPhyloBranch (lvl,idx) lbl l = PhyloBranch (lvl,idx) lbl l
+
+addPhyloBranch :: (Int,Int) -> Text ->  [PhyloGroupId] -> [PhyloBranch] -> [PhyloBranch]
+addPhyloBranch (lvl,idx) lbl ids b = b ++ [initPhyloBranch (lvl,idx) lbl ids]
+
+
+-- cur : current PhyloGroup 
+-- rst : rest of the initial list of PhyloGroups
+-- nxt : next PhyloGroups to be added in the current Branch 
+-- nbr : direct neighbours (Childs & Parents) of cur
+-- ids : PhyloGroupIds allready added in the current Branch 
+-- mem : memory of the allready created Branches 
+
+getGroupPairs :: PhyloGroup -> Phylo -> [PhyloGroup]
+getGroupPairs g p = (getGroupChilds g p) ++ (getGroupParents g p)
+
+
+groupsToBranchs :: (Int,Int) -> PhyloGroup -> [PhyloGroup] -> [PhyloGroup] -> [PhyloGroupId] -> [PhyloBranch] -> Phylo -> [PhyloBranch]
+groupsToBranchs (lvl,idx) curr rest next memId mem p 
+  | null rest && null next = addPhyloBranch  (lvl,idx) "" (memId ++ [getGroupId curr]) mem
+  | (not . null) next      = groupsToBranchs (lvl,idx) (head next') rest' (tail next') (memId ++ [getGroupId curr]) mem p
+  | otherwise              = groupsToBranchs (lvl,idx + 1) (head rest') (tail rest') [] [] (addPhyloBranch  (lvl,idx) "" (memId ++ [getGroupId curr]) mem) p 
+    where 
+      next' = nub $ next ++ (getGroupPairs curr p)
+      rest' = filter (\x -> not $ elem x next') rest   
+
+
+
+
+
+setPhyloBranches :: Level -> Phylo -> Phylo 
+setPhyloBranches lvl p = alterPhyloBranches (\branches 
+                                              -> branches ++ (groupsToBranchs 
+                                                              (getLevelValue lvl, 0)
+                                                              (head groups)
+                                                              (tail groups)
+                                                              [] [] [] p)) p
+  where 
+    --------------------------------------
+    groups :: [PhyloGroup]
+    groups = getGroupsWithLevel (getLevelValue lvl) p
+    --------------------------------------
+
+
+phyloWithBranches_1 = setPhyloBranches (initLevel 1 Level_1) phyloWithPair_1_Childs
+
 ------------------------------------------------------------------------
 -- | STEP 11 | -- Link the PhyloGroups of level 1 through the Periods  
 
@@ -130,7 +180,7 @@ 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 -> Double -> PhyloGroup -> Phylo -> [(PhyloGroupId, Double)]
 findBestCandidates to depth max thr s group p
-  | depth > max || (null . head) next = [] 
+  | depth > max || null next = [] 
   | (not . null) best = take 2 best
   | otherwise = findBestCandidates to (depth + 1) max thr s group p   
   where
@@ -166,25 +216,28 @@ 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 -> Double -> Phylo -> Phylo
-pairGroupsToGroups to lvl thr s p = alterPhyloGroupsWith 
+pairGroupsToGroups to lvl thr s p = alterPhyloGroups
                                     (\groups -> 
-                                      map (\group -> 
-                                            let
-                                              --------------------------------------
-                                              candidates :: [(PhyloGroupId, Double)] 
-                                              candidates = findBestCandidates to 1 5 thr s group p
-                                              --------------------------------------
-                                            in 
-                                              makePair to group candidates ) groups)
-                                    getGroupLevel (getLevelValue lvl) p
+                                      map (\group ->
+                                            if (getGroupLevel group) ==  (getLevelValue lvl)
+                                            then 
+                                              let
+                                                --------------------------------------
+                                                candidates :: [(PhyloGroupId, Double)] 
+                                                candidates = findBestCandidates to 1 5 thr s group p
+                                                --------------------------------------
+                                              in 
+                                                makePair to group candidates
+                                            else 
+                                              group ) groups) p
 
 
 phyloWithPair_1_Childs :: Phylo
-phyloWithPair_1_Childs = pairGroupsToGroups Childs (initLevel 1 Level_1) 0.1 0.5 phyloWithPair_1_Parents
+phyloWithPair_1_Childs = pairGroupsToGroups Childs (initLevel 1 Level_1) 0.01 0 phyloWithPair_1_Parents
 
 
 phyloWithPair_1_Parents :: Phylo
-phyloWithPair_1_Parents = pairGroupsToGroups Parents (initLevel 1 Level_1) 0.1 0.5 phyloLinked_0_1
+phyloWithPair_1_Parents = pairGroupsToGroups Parents (initLevel 1 Level_1) 0.01 0 phyloLinked_0_1
 
 
 ------------------------------------------------------------------------
@@ -526,7 +579,7 @@ phyloPeriods = groupDocsByPeriod 5 3 phyloDocs phylo
 
 -- | To init a Phylomemy
 initPhylo :: [Document] -> PhyloNgrams -> Phylo
-initPhylo docs ngrams = Phylo (both date $ (last &&& head) docs) ngrams []
+initPhylo docs ngrams = Phylo (both date $ (last &&& head) docs) ngrams [] []
 
 
 -- | To init a PhyloNgrams as a Vector of Ngrams 

src/Gargantext/Viz/Phylo/Tools.hs

@@ -19,7 +19,7 @@ module Gargantext.Viz.Phylo.Tools
 
 import Control.Lens         hiding (both, Level)
 import Data.List            (filter, intersect, (++), sort, null, head, tail, last)
-import Data.Map             (Map)
+import Data.Map             (Map, mapKeys, member)
 import Data.Set             (Set)
 import Data.Text            (Text)
 import Data.Tuple.Extra
@@ -50,19 +50,6 @@ alterPhyloGroups f p = over ( phylo_periods
                             . phylo_levelGroups
                             ) f p 
 
--- | To alter a sub list of PhyloGroups (filtered) following a given function
-alterPhyloGroupsWith :: Eq a => ([PhyloGroup] -> [PhyloGroup]) -> (PhyloGroup -> a) -> a -> Phylo -> Phylo
-alterPhyloGroupsWith f f' x p = over ( phylo_periods
-                            .  traverse
-                            . phylo_periodLevels
-                            .  traverse
-                            . phylo_levelGroups
-                            ) (f . subGroups) p
-    where
-        --------------------------------------
-        subGroups :: [PhyloGroup] -> [PhyloGroup] 
-        subGroups l = filterGroups f' x l
-        --------------------------------------
 
 -- | To alter each PhyloPeriod of a Phylo following a given function
 alterPhyloPeriods :: (PhyloPeriod -> PhyloPeriod) -> Phylo -> Phylo
@@ -70,6 +57,11 @@ alterPhyloPeriods f p = over ( phylo_periods
                              .  traverse) f p
 
 
+-- | To alter the list of PhyloBranches of a Phylo
+alterPhyloBranches :: ([PhyloBranch] -> [PhyloBranch]) -> Phylo -> Phylo
+alterPhyloBranches f p = over ( phylo_branches ) f p
+
+
 -- | To alter a list of PhyloLevels following a given function
 alterPhyloLevels :: ([PhyloLevel] -> [PhyloLevel]) -> Phylo -> Phylo
 alterPhyloLevels f p = over ( phylo_periods
@@ -120,6 +112,11 @@ filterNestedSets h l l'
   | otherwise              = filterNestedSets (head l) (tail l) (h : l')
 
 
+-- | To get the PhyloGroups Childs of a PhyloGroup
+getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
+getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p
+
+
 -- | To get the id of a PhyloGroup
 getGroupId :: PhyloGroup -> PhyloGroupId
 getGroupId = _phylo_groupId
@@ -140,6 +137,11 @@ getGroupNgrams :: PhyloGroup -> [Int]
 getGroupNgrams =  _phylo_groupNgrams
 
 
+-- | To get the PhyloGroups Parents of a PhyloGroup
+getGroupParents :: PhyloGroup -> Phylo -> [PhyloGroup]
+getGroupParents g p = getGroupsFromIds (map fst $ _phylo_groupPeriodParents g) p
+
+
 -- | To get the period out of the id of a PhyloGroup
 getGroupPeriod :: PhyloGroup -> (Date,Date)
 getGroupPeriod = fst . fst . getGroupId
@@ -155,11 +157,26 @@ getGroups = view ( phylo_periods
                  )
 
 
+-- | To 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 the PhyloGroup of a Phylo with a given level and period
 getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
-getGroupsWithFilters lvl prd p = (filterGroups getGroupLevel lvl (getGroups p))
+getGroupsWithFilters lvl prd p = (getGroupsWithLevel  lvl p)
                                  `intersect`
-                                 (filterGroups getGroupPeriod prd (getGroups p))
+                                 (getGroupsWithPeriod prd p)
+
+
+-- | To get all the PhyloGroup of a Phylo with a given Level
+getGroupsWithLevel :: Int -> Phylo -> [PhyloGroup]
+getGroupsWithLevel lvl p = filterGroups getGroupLevel lvl (getGroups p)
+
+
+-- | To get all the PhyloGroup of a Phylo with a given Period
+getGroupsWithPeriod :: (Date,Date) -> Phylo -> [PhyloGroup]
+getGroupsWithPeriod prd p = filterGroups getGroupPeriod prd (getGroups p)
 
 
 -- | To get the index of an element of a Vector
@@ -195,6 +212,11 @@ getLevelLinkValue dir link = case dir of
     _    -> panic "[ERR][Viz.Phylo.Tools.getLevelLinkValue] Wrong direction"
 
 
+-- | To get the Branches of a Phylo
+getPhyloBranches :: Phylo -> [PhyloBranch] 
+getPhyloBranches = _phylo_branches
+
+
 -- | To get all the Phylolevels of a given PhyloPeriod
 getPhyloLevels :: PhyloPeriod -> [PhyloLevel]
 getPhyloLevels = view (phylo_periodLevels)