[FIX] Shared lists is taken into account now
[gargantext.git] / src / Gargantext / Core / Viz / Phylo / PhyloTools.hs
index ac9a80d70e608d79a5988aa3e36cb982db74e772..b701f15488786cb9cee5e9a381867f765f6e4b03 100644 (file)
@@ -13,11 +13,13 @@ Portability : POSIX
 module Gargantext.Core.Viz.Phylo.PhyloTools where
 
 import Data.Vector (Vector, elemIndex)
-import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy)
+import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy, group)
 import Data.Set (Set, disjoint)
-import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty)
+import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
 import Data.String (String)
-import Data.Text (Text, unwords)
+import Data.Text (Text)
+
+import Prelude (floor)
 
 import Gargantext.Prelude
 import Gargantext.Core.Viz.AdaptativePhylo
@@ -31,6 +33,7 @@ import qualified Data.Vector as Vector
 import qualified Data.List as List
 import qualified Data.Set as Set
 import qualified Data.Map as Map
+import qualified Data.Text as Text
 
 ------------
 -- | Io | --
@@ -55,6 +58,22 @@ printIOComment cmt =
 -- | Misc | --
 --------------
 
+-- truncate' :: Double -> Int -> Double
+-- truncate' x n = (fromIntegral (floor (x * t))) / t
+--     where t = 10^n
+
+truncate' :: Double -> Int -> Double
+truncate' x n = (fromIntegral $ (floor (x * t) :: Int)) / t
+    where 
+        --------------
+        t :: Double
+        t = 10 ^n
+
+getInMap :: Int -> Map Int Double -> Double
+getInMap k m = 
+    if (member k m)
+        then m ! k
+        else 0
 
 roundToStr :: (PrintfArg a, Floating a) => Int -> a -> String
 roundToStr = printf "%0.*f"
@@ -98,8 +117,13 @@ ngramsToIdx ns fdt = map (\n -> fromJust $ elemIndex n fdt) ns
 
 -- | To transform a list of Ngrams Indexes into a Label
 ngramsToLabel :: Vector Ngrams -> [Int] -> Text
-ngramsToLabel ngrams l = unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
+ngramsToLabel ngrams l = Text.unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
 
+idxToLabel :: [Int] -> String
+idxToLabel l = List.unwords $ tail' "idxToLabel" $ concat $ map (\n -> ["|",show n]) l
+
+idxToLabel' :: [Double] -> String
+idxToLabel' l = List.unwords $ tail' "idxToLabel" $ concat $ map (\n -> ["|",show n]) l
 
 -- | To transform a list of Ngrams Indexes into a list of Text
 ngramsToText :: Vector Ngrams -> [Int] -> [Text]
@@ -253,22 +277,19 @@ ngramsToCooc ngrams coocs =
 --------------------
 
 getGroupId :: PhyloGroup -> PhyloGroupId 
-getGroupId group = ((group ^. phylo_groupPeriod, group ^. phylo_groupLevel), group ^. phylo_groupIndex)
+getGroupId g = ((g ^. phylo_groupPeriod, g ^. phylo_groupLevel), g ^. phylo_groupIndex)
 
 idToPrd :: PhyloGroupId -> PhyloPeriodId
 idToPrd id = (fst . fst) id
 
-getGroupThr :: PhyloGroup -> Double
-getGroupThr group = last' "getGroupThr" ((group ^. phylo_groupMeta) ! "breaks")
-
 groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] ->  Map a [PhyloGroup]
 groupByField toField groups = fromListWith (++) $ map (\g -> (toField g, [g])) groups
 
 getPeriodPointers :: Filiation -> PhyloGroup -> [Pointer]
-getPeriodPointers fil group = 
+getPeriodPointers fil g = 
     case fil of 
-        ToChilds  -> group ^. phylo_groupPeriodChilds
-        ToParents -> group ^. phylo_groupPeriodParents
+        ToChilds  -> g ^. phylo_groupPeriodChilds
+        ToParents -> g ^. phylo_groupPeriodParents
 
 filterProximity :: Proximity -> Double -> Double -> Bool
 filterProximity proximity thr local = 
@@ -287,14 +308,14 @@ getProximityName proximity =
 ---------------
 
 addPointers :: Filiation -> PointerType -> [Pointer] -> PhyloGroup -> PhyloGroup
-addPointers fil pty pointers group = 
+addPointers fil pty pointers g = 
     case pty of 
         TemporalPointer -> case fil of 
-                                ToChilds  -> group & phylo_groupPeriodChilds  .~ pointers
-                                ToParents -> group & phylo_groupPeriodParents .~ pointers
+                                ToChilds  -> g & phylo_groupPeriodChilds  .~ pointers
+                                ToParents -> g & phylo_groupPeriodParents .~ pointers
         LevelPointer    -> case fil of 
-                                ToChilds  -> group & phylo_groupLevelChilds   .~ pointers
-                                ToParents -> group & phylo_groupLevelParents  .~ pointers
+                                ToChilds  -> g & phylo_groupLevelChilds   .~ pointers
+                                ToParents -> g & phylo_groupLevelParents  .~ pointers
 
 
 getPeriodIds :: Phylo -> [(Date,Date)]
@@ -371,12 +392,12 @@ updatePhyloGroups lvl m phylo =
          .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
          . phylo_levelGroups
          .  traverse 
-         ) (\group -> 
-                let id = getGroupId group
+         ) (\g -> 
+                let id = getGroupId g
                 in 
                     if member id m 
                     then m ! id
-                    else group ) phylo
+                    else g ) phylo
 
 
 traceToPhylo :: Level -> Phylo -> Phylo
@@ -389,6 +410,43 @@ traceToPhylo lvl phylo =
 -- | Clustering | --
 --------------------
 
+mergeBranchIds :: [[Int]] -> [Int]
+mergeBranchIds ids = (head' "mergeBranchIds" . sort . mostFreq') ids
+  where
+    -- | 2) find the most Up Left ids in the hierarchy of similarity
+    -- mostUpLeft :: [[Int]] -> [[Int]]
+    -- mostUpLeft ids' = 
+    --      let groupIds = (map (\gIds -> (length $ head' "gIds" gIds, head' "gIds" gIds)) . groupBy (\id id' -> length id == length id') . sortOn length) ids'
+    --          inf = (fst . minimum) groupIds
+    --      in map snd $ filter (\gIds -> fst gIds == inf) groupIds
+    -- | 1) find the most frequent ids
+    mostFreq' :: [[Int]] -> [[Int]]
+    mostFreq' ids' = 
+       let groupIds = (map (\gIds -> (length gIds, head' "gIds" gIds)) . group . sort) ids'
+           sup = (fst . maximum) groupIds
+        in map snd $ filter (\gIds -> fst gIds == sup) groupIds
+
+
+mergeMeta :: [Int] -> [PhyloGroup] -> Map Text [Double]
+mergeMeta bId groups = 
+  let ego = head' "mergeMeta" $ filter (\g -> (snd (g ^. phylo_groupBranchId)) == bId) groups  
+   in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")]   
+
+
+groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
+groupsToBranches groups =
+    {- run the related component algorithm -}
+    let egos  = map (\g -> [getGroupId g] 
+                        ++ (map fst $ g ^. phylo_groupPeriodParents)
+                        ++ (map fst $ g ^. phylo_groupPeriodChilds)
+                        ++ (map fst $ g ^. phylo_groupAncestors)) $ elems groups
+        graph = relatedComponents egos
+    {- update each group's branch id -}
+    in map (\ids ->
+        let groups' = elems $ restrictKeys groups (Set.fromList ids)
+            bId = mergeBranchIds $ map (\g -> snd $ g ^. phylo_groupBranchId) groups'
+         in map (\g -> g & phylo_groupBranchId %~ (\(lvl,_) -> (lvl,bId))) groups') graph
+
 relatedComponents :: Ord a => [[a]] -> [[a]]
 relatedComponents graph = foldl' (\acc groups ->
     if (null acc)