[Community] Query search contact with text query on documents
[gargantext.git] / src / Gargantext / Viz / Phylo / PhyloExport.hs
index f5fa52a606a73dfa71c801caf860d732d2743073..e7b539962cc02dc54d10daaf1fa68af0d702abea 100644 (file)
@@ -8,23 +8,18 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances    #-}
 
 module Gargantext.Viz.Phylo.PhyloExport where
 
 import Data.Map (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault, toList)
-import Data.List ((++), sort, nub, concat, sortOn, reverse, groupBy, union, (\\), (!!), init, partition, unwords, nubBy, inits)
+import Data.List ((++), sort, nub, concat, sortOn, reverse, groupBy, union, (\\), (!!), init, partition, unwords, nubBy, inits, elemIndex)
 import Data.Vector (Vector)
 
 import Prelude (writeFile)
 import Gargantext.Prelude
 import Gargantext.Viz.AdaptativePhylo
-import Gargantext.Viz.Phylo.PhyloTools 
+import Gargantext.Viz.Phylo.PhyloTools
 
 import Control.Lens
 import Data.GraphViz hiding (DotGraph, Order)
@@ -35,6 +30,7 @@ import Data.Text.Lazy (fromStrict, pack, unpack)
 import System.FilePath
 import Debug.Trace (trace)
 
+import qualified Data.Map as Map
 import qualified Data.Text as Text
 import qualified Data.Vector as Vector
 import qualified Data.Text.Lazy as Lazy
@@ -110,12 +106,13 @@ groupToTable fdt g = H.Table H.HTable
                                    <> (pack $ show (getGroupId g)))]] 
         --------------------------------------
 
-branchToDotNode :: PhyloBranch -> Dot DotId
-branchToDotNode b = 
+branchToDotNode :: PhyloBranch -> Int -> Dot DotId
+branchToDotNode b bId 
     node (branchIdToDotId $ b ^. branch_id)
          ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ b ^. branch_label)]
          <> (metaToAttr $ b ^. branch_meta)
          <> [ toAttr "nodeType" "branch"
+            , toAttr "bId"      (pack $ show bId)
             , toAttr "branchId" (pack $ unwords (map show $ snd $ b ^. branch_id))
             , toAttr "branch_x" (fromStrict $ Text.pack $ (show $ b ^. branch_x))
             , toAttr "branch_y" (fromStrict $ Text.pack $ (show $ b ^. branch_y))
@@ -131,14 +128,15 @@ periodToDotNode prd =
             , toAttr "to"   (fromStrict $ Text.pack $ (show $ snd prd))])
 
 
-groupToDotNode :: Vector Ngrams -> PhyloGroup -> Dot DotId
-groupToDotNode fdt g = 
+groupToDotNode :: Vector Ngrams -> PhyloGroup -> Int -> Dot DotId
+groupToDotNode fdt g bId 
     node (groupIdToDotId $ getGroupId g)
                      ([FontName "Arial", Shape Square, penWidth 4,  toLabel (groupToTable fdt g)]
                       <> [ toAttr "nodeType" "group"
                          , toAttr "from" (pack $ show (fst $ g ^. phylo_groupPeriod))
                          , toAttr "to"   (pack $ show (snd $ g ^. phylo_groupPeriod))
                          , toAttr "branchId" (pack $ unwords (init $ map show $ snd $ g ^. phylo_groupBranchId))
+                         , toAttr "bId" (pack $ show bId)
                          , toAttr "support" (pack $ show (g ^. phylo_groupSupport))])  
 
 
@@ -146,9 +144,9 @@ toDotEdge :: DotId -> DotId -> Text.Text -> EdgeType -> Dot DotId
 toDotEdge source target lbl edgeType = edge source target
     (case edgeType of
         GroupToGroup   -> [ Width 3, penWidth 4, Color [toWColor Black], Constraint True
-                          , Label (StrLabel $ fromStrict lbl)]
+                          , Label (StrLabel $ fromStrict lbl)] <> [toAttr "edgeType" "link" ]
         BranchToGroup  -> [ Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])
-                          , Label (StrLabel $ fromStrict lbl)]
+                          , Label (StrLabel $ fromStrict lbl)] <> [toAttr "edgeType" "branchLink" ]
         BranchToBranch -> [ Width 2, Color [toWColor Black], Style [SItem Dashed []], ArrowHead (AType [(ArrMod FilledArrow BothSides,DotArrow)])
                           , Label (StrLabel $ fromStrict lbl)]
         PeriodToPeriod -> [ Width 5, Color [toWColor Black]])
@@ -161,6 +159,11 @@ mergePointers groups =
     in  unionWith (\w w' -> max w w') toChilds toParents
 
 
+toBid :: PhyloGroup -> [PhyloBranch] -> Int
+toBid g bs = 
+  let b' = head' "toBid" (filter (\b -> b ^. branch_id == g ^. phylo_groupBranchId) bs)
+   in fromJust $ elemIndex b' bs
+
 exportToDot :: Phylo -> PhyloExport -> DotGraph DotId
 exportToDot phylo export = 
     trace ("\n-- | Convert " <> show(length $ export ^. export_branches) <> " branches and "
@@ -169,12 +172,12 @@ exportToDot phylo export =
          <> "##########################") $
     digraph ((Str . fromStrict) $ (phyloName $ getConfig phylo)) $ do 
 
-        -- | 1) init the dot graph
+        {- 1) init the dot graph -}
         graphAttrs ( [ Label (toDotLabel $ (phyloName $ getConfig phylo))]
                   <> [ FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
                      , Ratio FillRatio
                      , Style [SItem Filled []],Color [toWColor White]]
-                  -- | home made attributes
+                  {-- home made attributes -}
                   <> [(toAttr (fromStrict "phyloFoundations") $ pack $ show (length $ Vector.toList $ getRoots phylo))
                      ,(toAttr (fromStrict "phyloTerms") $ pack $ show (length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) $ export ^. export_groups))
                      ,(toAttr (fromStrict "phyloDocs") $ pack $ show (sum $ elems $ phylo ^. phylo_timeDocs))
@@ -183,36 +186,36 @@ exportToDot phylo export =
                      ,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups))
                      ])
 
-
+{-
  -- toAttr (fromStrict k) $ (pack . unwords) $ map show v
 
-        -- | 2) create a layer for the branches labels
+        --  2) create a layer for the branches labels -}
         subgraph (Str "Branches peaks") $ do 
 
             graphAttrs [Rank SameRank]
-
-            -- | 3) group the branches by hierarchy
+{-
+            --  3) group the branches by hierarchy
             -- mapM (\branches -> 
             --         subgraph (Str "Branches clade") $ do
             --             graphAttrs [Rank SameRank]
 
-            --             -- | 4) create a node for each branch
+            --             --  4) create a node for each branch
             --             mapM branchToDotNode branches
             --     ) $ elems $ fromListWith (++) $ map (\b -> ((init . snd) $ b ^. branch_id,[b])) $ export ^. export_branches
+-}
+            mapM (\b -> branchToDotNode b (fromJust $ elemIndex b (export ^. export_branches))) $ export ^. export_branches
 
-            mapM branchToDotNode $ export ^. export_branches
-
-        -- | 5) create a layer for each period
+        {--  5) create a layer for each period -}
         _ <- mapM (\period ->
                 subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst period) <> show (snd period))) $ do 
                     graphAttrs [Rank SameRank]
                     periodToDotNode period
 
-                    -- | 6) create a node for each group 
-                    mapM (\g -> groupToDotNode (getRoots phylo) g) (filter (\g -> g ^. phylo_groupPeriod == period) $ export ^. export_groups)
+                    {--  6) create a node for each group -}
+                    mapM (\g -> groupToDotNode (getRoots phylo) g (toBid g (export ^. export_branches))) (filter (\g -> g ^. phylo_groupPeriod == period) $ export ^. export_groups)
             ) $ getPeriodIds phylo
 
-        -- | 7) create the edges between a branch and its first groups
+        {--  7) create the edges between a branch and its first groups -}
         _ <- mapM (\(bId,groups) ->
                 mapM (\g -> toDotEdge (branchIdToDotId bId) (groupIdToDotId $ getGroupId g) "" BranchToGroup) groups 
              )
@@ -222,31 +225,29 @@ exportToDot phylo export =
                            $ sortOn (fst . _phylo_groupPeriod) groups) 
            $ fromListWith (++) $ map (\g -> (g ^. phylo_groupBranchId,[g])) $ export ^. export_groups
 
-        -- | 8) create the edges between the groups
+        {-  8) create the edges between the groups -}
         _ <- mapM (\((k,k'),_) -> 
                 toDotEdge (groupIdToDotId k) (groupIdToDotId k') "" GroupToGroup
             ) $ (toList . mergePointers) $ export ^. export_groups
 
-        -- | 7) create the edges between the periods 
+        {-  7) create the edges between the periods -}
         _ <- mapM (\(prd,prd') ->
                 toDotEdge (periodIdToDotId prd) (periodIdToDotId prd') "" PeriodToPeriod
             ) $ nubBy (\combi combi' -> fst combi == fst combi') $ listToCombi' $ getPeriodIds phylo
 
-        -- | 8) create the edges between the branches 
+        {-  8) create the edges between the branches 
         -- _ <- mapM (\(bId,bId') ->
         --         toDotEdge (branchIdToDotId bId) (branchIdToDotId bId') 
         --         (Text.pack $ show(branchIdsToProximity bId bId' 
         --                             (getThresholdInit $ phyloProximity $ getConfig phylo)
         --                             (getThresholdStep $ phyloProximity $ getConfig phylo))) BranchToBranch
         --     ) $ nubBy (\combi combi' -> fst combi == fst combi') $ listToCombi' $ map _branch_id $ export ^. export_branches
+        -}
 
 
         graphAttrs [Rank SameRank]
 
 
-        
-
-
 ----------------
 -- | Filter | --
 ----------------
@@ -270,11 +271,25 @@ processFilters filters qua export =
 -- | Sort | --
 --------------
 
+branchToIso :: [PhyloBranch] -> [PhyloBranch]
+branchToIso branches =
+    let steps = map sum
+              $ inits
+              $ map (\(b,x) -> b ^. branch_y + 0.05 - x)
+              $ zip branches 
+              $ ([0] ++ (map (\(b,b') -> 
+                                 let idx = length $ commonPrefix (b ^. branch_canonId) (b' ^. branch_canonId) []
+                                  in (b' ^. branch_seaLevel) !! (idx - 1)
+                                 ) $ listToSeq branches))
+     in map (\(x,b) -> b & branch_x .~ x)
+      $ zip steps branches
+
+
 sortByHierarchy :: Int -> [PhyloBranch] -> [PhyloBranch]
 sortByHierarchy depth branches =
     if (length branches == 1)
-        then branches
-        else concat 
+        then branchToIso branches
+        else branchToIso $ concat 
            $ map (\branches' ->
                     let partitions = partition (\b -> depth + 1 == ((length . snd) $ b ^. branch_id)) branches'
                     in  (sortOn (\b -> (b ^. branch_meta) ! "birth") (fst partitions))
@@ -423,13 +438,13 @@ toDynamics n parents g m =
     let prd = g ^. phylo_groupPeriod
         end = last' "dynamics" (sort $ map snd $ elems m)
     in  if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
-            -- | decrease
+            {- decrease -}
             then 2
         else if ((fst prd) == (fst $ m ! n))
-            -- | recombination
+            {- recombination -}
             then 0
         else if isNew
-            -- | emergence
+            {- emergence -}
             then 1
         else 3
     where
@@ -455,11 +470,31 @@ processDynamics groups =
                                             $ (g ^. phylo_groupNgrams))) [] groups
 
 
+-----------------
+-- | horizon | --
+-----------------
+
+horizonToAncestors :: Double -> Phylo -> [PhyloAncestor]
+horizonToAncestors delta phylo = 
+  let horizon = Map.toList $ Map.filter (\v -> v > delta) $ phylo ^. phylo_horizon
+      ct0 = fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevelPeriods 1 (take 1 (getPeriodIds phylo)) phylo
+      aDelta = toRelatedComponents
+                  (elems ct0)
+                  (map (\((g,g'),v) -> ((ct0 ! g,ct0 ! g'),v)) horizon)
+   in map (\(id,groups) -> toAncestor id groups) $ zip [1..] aDelta
+  where 
+    -- | note : possible bug if we sync clus more than once
+    -- | horizon is calculated at level 1, ancestors have to be related to the last level
+    toAncestor :: Int -> [PhyloGroup] -> PhyloAncestor
+    toAncestor id groups = PhyloAncestor id 
+                              (foldl' (\acc g -> union acc (g ^. phylo_groupNgrams)) [] groups) 
+                              (concat $ map (\g -> map fst (g ^. phylo_groupLevelParents)) groups) 
+
+
 ---------------------
 -- | phyloExport | --
 ---------------------   
 
-
 toPhyloExport :: Phylo -> DotGraph DotId
 toPhyloExport phylo = exportToDot phylo
                     $ processFilters (exportFilter $ getConfig phylo) (phyloQuality $ getConfig phylo)
@@ -468,30 +503,20 @@ toPhyloExport phylo = exportToDot phylo
                     $ processMetrics  export           
     where
         export :: PhyloExport
-        export = PhyloExport groups
-               $ map (\(x,b) -> b & branch_x .~ x)
-               $ zip branchesGaps branches
-        --------------------------------------
-        branchesGaps :: [Double]
-        branchesGaps = map sum
-                     $ inits
-                     $ map (\(b,x) -> b ^. branch_y + 0.05 - x)
-                     $ zip branches 
-                     $ ([0] ++ (map (\(b,b') -> 
-                                        let idx = length $ commonPrefix (b ^. branch_canonId) (b' ^. branch_canonId) []
-                                         in (b' ^. branch_seaLevel) !! (idx - 1)
-                                        ) $ listToSeq branches))
+        export = PhyloExport groups branches (horizonToAncestors 0 phylo)     
         --------------------------------------
         branches :: [PhyloBranch]
         branches = map (\g -> 
                       let seaLvl = (g ^. phylo_groupMeta) ! "seaLevels"
                           breaks = (g ^. phylo_groupMeta) ! "breaks"
                           canonId = take (round $ (last' "export" breaks) + 2) (snd $ g ^. phylo_groupBranchId)
-                       in trace (show(canonId)) $ PhyloBranch (g ^. phylo_groupBranchId) 
+                       in PhyloBranch (g ^. phylo_groupBranchId) 
                                       canonId
                                       seaLvl
                                       0 
                                       (last' "export" (take (round $ (last' "export" breaks) + 1) seaLvl))
+                                      0
+                                      0
                                       "" empty)  
                   $ map (\gs -> head' "export" gs)
                   $ groupBy (\g g' -> g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)