Merge branch '81-dev-zip-upload' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell...
[gargantext.git] / src / Gargantext / Core / Viz / Phylo / PhyloExport.hs
index 5452a33ccf5506a4253810acfadd2e4abdd90296..b67a69c94c724fd0b92da8a391c4e7927cda4748 100644 (file)
@@ -13,7 +13,7 @@ Portability : POSIX
 module Gargantext.Core.Viz.Phylo.PhyloExport where
 
 import Data.Map (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault, toList, member)
-import Data.List ((++), sort, nub, null, concat, sortOn, reverse, groupBy, union, (\\), (!!), init, partition, notElem, unwords, nubBy, inits, elemIndex)
+import Data.List ((++), sort, nub, null, concat, sortOn, groupBy, union, (\\), (!!), init, partition, notElem, unwords, nubBy, inits, elemIndex)
 import Data.Vector (Vector)
 
 import Prelude (writeFile)
@@ -120,11 +120,13 @@ branchToDotNode b bId =
             , toAttr "label"    (pack $ show $ b ^. branch_label)
             ])
  
-periodToDotNode :: (Date,Date) -> Dot DotId
-periodToDotNode prd =
+periodToDotNode :: (Date,Date) -> (Text.Text,Text.Text) -> Dot DotId
+periodToDotNode prd prd' =
     node (periodIdToDotId prd)
          ([Shape BoxShape, FontSize 50, Label (toDotLabel $ Text.pack (show (fst prd) <> " " <> show (snd prd)))]
-         <> [ toAttr "nodeType" "period" 
+         <> [ toAttr "nodeType" "period"
+            , toAttr "strFrom" (fromStrict $ Text.pack $ (show $ fst prd'))
+            , toAttr "strTo"   (fromStrict $ Text.pack $ (show $ snd prd'))          
             , toAttr "from" (fromStrict $ Text.pack $ (show $ fst prd))
             , toAttr "to"   (fromStrict $ Text.pack $ (show $ snd prd))])
 
@@ -136,12 +138,17 @@ groupToDotNode fdt g bId =
                       <> [ toAttr "nodeType" "group"
                          , toAttr "from" (pack $ show (fst $ g ^. phylo_groupPeriod))
                          , toAttr "to"   (pack $ show (snd $ g ^. phylo_groupPeriod))
+                         , toAttr "strFrom" (pack $ show (fst $ g ^. phylo_groupPeriod'))
+                         , toAttr "strTo"   (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))
+                         , toAttr "weight" (pack $ show (g ^. phylo_groupWeight))
+                         , toAttr "source" (pack $ show (nub $ g ^. phylo_groupSources))
                          , toAttr "lbl" (pack $ show (ngramsToLabel fdt (g ^. phylo_groupNgrams)))
                          , toAttr "foundation" (pack $ show (idxToLabel (g ^. phylo_groupNgrams)))
                          , toAttr "role" (pack $ show (idxToLabel' ((g ^. phylo_groupMeta) ! "dynamics")))
+                         , toAttr "frequence" (pack $ show (idxToLabel' ((g ^. phylo_groupMeta) ! "frequence")))
                          ])  
 
 
@@ -192,7 +199,9 @@ exportToDot phylo export =
                      ,(toAttr (fromStrict "phyloPeriods") $ pack $ show (length $ elems $ phylo ^. phylo_periods))
                      ,(toAttr (fromStrict "phyloBranches") $ pack $ show (length $ export ^. export_branches))
                      ,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups))
-                     ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo))
+                     ,(toAttr (fromStrict "phyloSources") $ pack $ show (Vector.toList $ getSources phylo))
+                     ,(toAttr (fromStrict "phyloTimeScale") $ pack $ getTimeScale phylo)
+                     -- ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo))
                      ])
 
 {-
@@ -201,7 +210,7 @@ exportToDot phylo export =
         --  2) create a layer for the branches labels -}
         subgraph (Str "Branches peaks") $ do 
 
-            graphAttrs [Rank SameRank]
+            -- graphAttrs [Rank SameRank]
 {-
             --  3) group the branches by hierarchy
             -- mapM (\branches -> 
@@ -216,13 +225,13 @@ exportToDot phylo export =
 
         {--  5) create a layer for each period -}
         _ <- mapM (\period ->
-                subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst period) <> show (snd period))) $ do 
+                subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst $ _phylo_periodPeriod period) <> show (snd $ _phylo_periodPeriod period))) $ do 
                     graphAttrs [Rank SameRank]
-                    periodToDotNode period
+                    periodToDotNode (period ^. phylo_periodPeriod) (period ^. phylo_periodPeriod')
 
                     {--  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
+                    mapM (\g -> groupToDotNode (getRoots phylo) g (toBid g (export ^. export_branches))) (filter (\g -> g ^. phylo_groupPeriod == (period ^. phylo_periodPeriod)) $ export ^. export_groups)
+            ) $ phylo ^. phylo_periods
 
         {--  7) create the edges between a branch and its first groups -}
         _ <- mapM (\(bId,groups) ->
@@ -243,7 +252,7 @@ exportToDot phylo export =
                 toDotEdge (groupIdToDotId k) (groupIdToDotId k') (show v) GroupToAncestor
           ) $ mergeAncestors $ export ^. export_groups
 
-        -- 10) create the edges between the periods 
+        -- 10) 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
@@ -368,8 +377,8 @@ inclusion m l i = ( (sum $ map (\j -> conditional m j i) l)
                   + (sum $ map (\j -> conditional m i j) l)) / (fromIntegral $ (length l) + 1)
 
 
-ngramsMetrics :: PhyloExport -> PhyloExport
-ngramsMetrics export =
+ngramsMetrics :: Phylo -> PhyloExport -> PhyloExport
+ngramsMetrics phylo export =
     over ( export_groups
          .  traverse )
     (\g -> g & phylo_groupMeta %~ insert "genericity" 
@@ -378,6 +387,8 @@ ngramsMetrics export =
                                   (map (\n -> specificity (g ^. phylo_groupCooc) ((g ^. phylo_groupNgrams) \\ [n]) n) $ g ^. phylo_groupNgrams)
              & phylo_groupMeta %~ insert "inclusion" 
                                   (map (\n -> inclusion   (g ^. phylo_groupCooc) ((g ^. phylo_groupNgrams) \\ [n]) n) $ g ^. phylo_groupNgrams)
+             & phylo_groupMeta %~ insert "frequence" 
+                                  (map (\n -> getInMap n (phylo ^. phylo_lastTermFreq)) $ g ^. phylo_groupNgrams)                                  
         ) export
 
 
@@ -397,9 +408,9 @@ branchDating export =
              & branch_meta %~ insert "age"   [fromIntegral age]
              & branch_meta %~ insert "size"  [fromIntegral $ length periods] ) export
 
-processMetrics :: PhyloExport -> PhyloExport
-processMetrics export = ngramsMetrics
-                      $ branchDating export 
+processMetrics :: Phylo -> PhyloExport -> PhyloExport
+processMetrics phylo export = ngramsMetrics phylo
+                            $ branchDating export 
 
 
 -----------------
@@ -598,8 +609,10 @@ toHorizon phylo =
     mapGroups :: [[PhyloGroup]]
     mapGroups = map (\prd -> 
       let groups  = getGroupsFromLevelPeriods level [prd] phylo
-          childs  = getPreviousChildIds level frame prd periods phylo     
-          heads   = filter (\g -> null (g ^. phylo_groupPeriodParents) && (notElem (getGroupId g) childs)) groups
+          childs  = getPreviousChildIds level frame prd periods phylo 
+              -- maybe add a better filter for non isolated  ancestors
+          heads   = filter (\g -> (not . null) $ (g ^. phylo_groupPeriodChilds))
+                  $ filter (\g -> null (g ^. phylo_groupPeriodParents) && (notElem (getGroupId g) childs)) groups
           noHeads = groups \\ heads 
           nbDocs  = sum $ elems  $ filterDocs  (phylo ^. phylo_timeDocs) [prd]
           diago   = reduceDiagos $ filterDiago (phylo ^. phylo_timeCooc) [prd]
@@ -630,7 +643,7 @@ toPhyloExport phylo = exportToDot phylo
                     $ processFilters (exportFilter $ getConfig phylo) (phyloQuality $ getConfig phylo)
                     $ processSort    (exportSort   $ getConfig phylo) (getSeaElevation phylo)
                     $ processLabels  (exportLabel  $ getConfig phylo) (getRoots phylo) (_phylo_lastTermFreq phylo)
-                    $ processMetrics  export           
+                    $ processMetrics phylo export           
     where
         export :: PhyloExport
         export = PhyloExport groups branches     
@@ -656,8 +669,8 @@ toPhyloExport phylo = exportToDot phylo
         groups = traceExportGroups
                $ processDynamics
                $ getGroupsFromLevel (phyloLevel $ getConfig phylo)
-               $ tracePhyloInfo 
-               $ toHorizon phylo
+               $ tracePhyloInfo phylo
+               -- \$ toHorizon phylo
 
 
 traceExportBranches :: [PhyloBranch] -> [PhyloBranch]
@@ -665,12 +678,10 @@ traceExportBranches branches = trace ("\n"
   <> "-- | Export " <> show(length branches) <> " branches") branches
 
 tracePhyloAncestors :: [[PhyloGroup]] -> [[PhyloGroup]]
-tracePhyloAncestors groups = trace ("\n" 
-  <> "-- | Found " <> show(length $ concat $ map _phylo_groupAncestors $ concat groups) <> " ancestors"
-  ) groups
+tracePhyloAncestors groups = trace ( "-- | Found " <> show(length $ concat $ map _phylo_groupAncestors $ concat groups) <> " ancestors") groups
 
 tracePhyloInfo :: Phylo -> Phylo
-tracePhyloInfo phylo = trace ("\n"  <> "##########################" <> "\n\n" <> "-- | Phylo with � = "
+tracePhyloInfo phylo = trace ("\n"  <> "##########################" <> "\n\n" <> "-- | Phylo with � = "
     <> show(_qua_granularity $ phyloQuality $ getConfig phylo) <> " applied to "
     <> show(length $ Vector.toList $ getRoots phylo) <> " foundations"
   ) phylo