fix timeMatching for level > 1

bin/gargantext-phylo/Main.hs

@@ -167,7 +167,7 @@ main = do
 
       let roots = DL.nub $ DL.concat $ map text corpus
 
-      putStrLn $ (show (length corpus) <> " parsed docs")
+      putStrLn $ ("\n" <> show (length corpus) <> " parsed docs")
       
       let query = PhyloQueryBuild (phyloName conf) "" (timeGrain conf) (timeStep conf) 
                   (Fis $ FisParams True (fisSupport conf) (fisClique conf)) [] [] (WeightedLogJaccard $ WLJParams (timeTh conf) (timeSens conf)) (phyloLevel conf)

src/Gargantext/Viz/Phylo/Aggregates/Fis.hs

@@ -21,7 +21,6 @@ import Data.List        (null,concat,sort)
 import Data.Map         (Map, empty,elems)
 import Data.Tuple       (fst, snd)
 import Data.Set         (size)
-import Data.Vector.Storable  (Vector)
 import Gargantext.Prelude
 import Gargantext.Text.Metrics.FrequentItemSet  (fisWithSizePolyMap, Size(..))
 import Gargantext.Viz.Phylo
@@ -35,20 +34,21 @@ import Numeric.Statistics (percentile)
 import Debug.Trace (trace)
 
 
--- | To Filter Fis by support 
-filterFisBySupport :: Bool -> Int -> Map (Date, Date) [PhyloFis] -> Map (Date, Date) [PhyloFis]
-filterFisBySupport keep min' m = case keep of
-  False -> Map.map (\l -> filterMinorFis min' l) m
-  True  -> Map.map (\l -> keepFilled (filterMinorFis) min' l) m
+-- | To apply a filter with the possibility of keeping some periods non empty (keep : True|False)
+filterFis :: Bool -> Int -> (Int -> [PhyloFis] -> [PhyloFis]) -> Map (Date, Date) [PhyloFis] -> Map (Date, Date) [PhyloFis]
+filterFis keep thr f m = case keep of
+  False -> Map.map (\l -> f thr l) m
+  True  -> Map.map (\l -> keepFilled (f) thr l) m
 
 
-filterFisByNgrams :: Int -> Map (Date, Date) [PhyloFis] -> Map (Date, Date) [PhyloFis]
-filterFisByNgrams thr m = Map.map(\lst -> filter (\fis -> (size $ getClique fis) > thr) lst) m
+-- | To filter Fis with small Support
+filterFisBySupport :: Int -> [PhyloFis] -> [PhyloFis]
+filterFisBySupport thr l = filter (\fis -> getSupport fis > thr) l
 
 
--- | To filter Fis with small Support, to preserve nonempty periods please use : filterFisBySupport true
-filterMinorFis :: Int -> [PhyloFis] -> [PhyloFis]
-filterMinorFis min' l = filter (\fis -> getSupport fis > min') l
+-- | To filter Fis with small Clique size
+filterFisByClique :: Int -> [PhyloFis] -> [PhyloFis]
+filterFisByClique thr l = filter (\fis -> (size $ getClique fis) > thr) l
 
 
 -- | To filter nested Fis 
@@ -82,11 +82,11 @@ toPhyloFis :: Map (Date, Date) [Document] -> Bool -> Support -> Int -> [Metric]
 toPhyloFis ds k s t ms fs = processFilters fs  
                           $ processMetrics ms
                           $ traceFis "----\nFiltered Fis by clique size :\n"
-                          $ filterFisByNgrams t
+                          $ filterFis k t (filterFisByClique)
                           $ traceFis "----\nFiltered Fis by nested :\n"
                           $ filterFisByNested 
                           $ traceFis "----\nFiltered Fis by support :\n"
-                          $ filterFisBySupport k s
+                          $ filterFis k s (filterFisBySupport)
                           $ traceFis "----\nUnfiltered Fis :\n"
                           $ docsToFis ds  
 
@@ -95,19 +95,41 @@ toPhyloFis ds k s t ms fs = processFilters fs
 -- | Tracers | --
 -----------------
 
+
+
 traceFis :: [Char] -> Map (Date, Date) [PhyloFis] -> Map (Date, Date) [PhyloFis] 
 traceFis lbl m = trace (lbl <> "count : " <> show (sum $ map length $ elems m) <> " Fis\n"
-                            <> "support : " <> show (percentile 25 supps) <> " (25%) "
-                                            <> show (percentile 50 supps) <> " (50%) "
-                                            <> show (percentile 75 supps) <> " (75%) "
-                                            <> show (percentile 90 supps) <> " (90%)\n"
-                            <> "clique size : " <> show (percentile 25 ngrms) <> " (25%) "
-                                                <> show (percentile 50 ngrms) <> " (50%) "
-                                                <> show (percentile 75 ngrms) <> " (75%) "
-                                                <> show (percentile 90 ngrms) <> " (90%)\n"                                             
+                            <> "support : " <> show (percentile 25 (Vector.fromList supps)) <> " (25%) "
+                                            <> show (percentile 50 (Vector.fromList supps)) <> " (50%) "
+                                            <> show (percentile 75 (Vector.fromList supps)) <> " (75%) "
+                                            <> show (percentile 90 (Vector.fromList supps)) <> " (90%) "
+                                            <> show (percentile 100 (Vector.fromList supps)) <> " (100%)\n"
+                            <> "          " <> show (countSup 1 supps) <> " (>1) "
+                                            <> show (countSup 2 supps) <> " (>2) "
+                                            <> show (countSup 3 supps) <> " (>3) "
+                                            <> show (countSup 4 supps) <> " (>4) "
+                                            <> show (countSup 5 supps) <> " (>5) "
+                                            <> show (countSup 6 supps) <> " (>6)\n"                                                                                                                                          
+                            <> "clique size : " <> show (percentile 25 (Vector.fromList ngrms)) <> " (25%) "
+                                                <> show (percentile 50 (Vector.fromList ngrms)) <> " (50%) "
+                                                <> show (percentile 75 (Vector.fromList ngrms)) <> " (75%) "
+                                                <> show (percentile 90 (Vector.fromList ngrms)) <> " (90%) "
+                                                <> show (percentile 100 (Vector.fromList ngrms)) <> " (100%)\n"
+                            <> "              " <> show (countSup 1 ngrms) <> " (>1) "
+                                                <> show (countSup 2 ngrms) <> " (>2) "
+                                                <> show (countSup 3 ngrms) <> " (>3) "
+                                                <> show (countSup 4 ngrms) <> " (>4) "
+                                                <> show (countSup 5 ngrms) <> " (>5) "
+                                                <> show (countSup 6 ngrms) <> " (>6)\n"                                                                                             
                             ) m
-  where 
-    supps :: Vector Double
-    supps = Vector.fromList $ sort $ map (fromIntegral . _phyloFis_support) $ concat $ elems m
-    ngrms :: Vector Double
-    ngrms = Vector.fromList $ sort $ map (\f -> fromIntegral $ Set.size $ _phyloFis_clique f) $ concat $ elems m
+  where
+    --------------------------------------
+    countSup :: Double -> [Double] -> Int
+    countSup s l = length $ filter (>s) l 
+    --------------------------------------
+    supps :: [Double]
+    supps = sort $ map (fromIntegral . _phyloFis_support) $ concat $ elems m
+    --------------------------------------
+    ngrms :: [Double]
+    ngrms = sort $ map (\f -> fromIntegral $ Set.size $ _phyloFis_clique f) $ concat $ elems m
+    --------------------------------------
\ No newline at end of file

src/Gargantext/Viz/Phylo/Example.hs

@@ -77,7 +77,7 @@ queryViewEx = "level=3"
 
 
 phyloQueryView :: PhyloQueryView
-phyloQueryView = PhyloQueryView 4 Merge False 1 [BranchAge] [defaultSizeBranch] [BranchPeakFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True
+phyloQueryView = PhyloQueryView 4 Merge False 1 [BranchAge] [] [BranchPeakFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True
 
 
 --------------------------------------------------
@@ -104,7 +104,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.1 10) 5 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.1 10)
+             5 3 defaultFis [] [] (WeightedLogJaccard $ WLJParams 0.1 10) 4 (RelatedComponents $ RCParams $ WeightedLogJaccard $ WLJParams 0.1 10)
 
 
 
@@ -202,7 +202,9 @@ phylo1 =  addPhyloLevel (1) phyloFis phylo
 
 
 phyloFis :: Map (Date, Date) [PhyloFis]
-phyloFis = filterFisByNested $ filterFisBySupport True 1 (docsToFis phyloDocs)
+phyloFis = filterFis True 1 (filterFisByClique) 
+         $ filterFisByNested 
+         $ filterFis True 1 (filterFisBySupport) (docsToFis phyloDocs)
 
 
 ----------------------------------------

src/Gargantext/Viz/Phylo/LevelMaker.hs

@@ -141,10 +141,11 @@ toNthLevel lvlMax prox clus p
   | otherwise     = toNthLevel lvlMax prox clus
                   $ traceBranches (lvl + 1)
                   $ setPhyloBranches (lvl + 1)
-                  $ traceTempoMatching Descendant (lvl + 1)
-                  $ interTempoMatching Descendant (lvl + 1) prox
-                  $ traceTempoMatching Ascendant  (lvl + 1)
-                  $ interTempoMatching Ascendant  (lvl + 1) prox
+                  -- $ traceTempoMatching Descendant (lvl + 1)
+                  -- $ interTempoMatching Descendant (lvl + 1) prox
+                  -- $ traceTempoMatching Ascendant  (lvl + 1)
+                  -- $ interTempoMatching Ascendant  (lvl + 1) prox
+                  $ transposePeriodLinks (lvl + 1)
                   $ setLevelLinks (lvl, lvl + 1)
                   $ addPhyloLevel (lvl + 1)
                     (phyloToClusters lvl clus p) p
@@ -259,7 +260,7 @@ instance PhyloMaker [Document]
 
 
 tracePhyloBase :: Phylo -> Phylo
-tracePhyloBase p = trace ( "\n-----------------\n--| PhyloBase |--\n-----------------\n\n" 
+tracePhyloBase p = trace ( "\n-------------\n--| Phylo |--\n-------------\n\n" 
                         <> show (length $ _phylo_periods p) <> " periods from " 
                                  <> show (getPhyloPeriodId $ (head' "PhyloMaker") $ _phylo_periods p)
                                  <> " to " 

src/Gargantext/Viz/Phylo/LinkMaker.hs

@@ -20,7 +20,7 @@ module Gargantext.Viz.Phylo.LinkMaker
 import Control.Lens                 hiding (both, Level)
 import Data.List                    ((++), sortOn, null, tail, splitAt, elem, concat, sort, delete, intersect)
 import Data.Tuple.Extra
-import Data.Map                     (Map,(!))
+import Data.Map                     (Map,(!),fromListWith)
 import Gargantext.Prelude
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
@@ -152,7 +152,7 @@ addPointers' fil pts g = g & case fil of
 
 
 
--- | To update a list of pkyloGroups with some Pointers
+-- | To update a list of phyloGroups with some Pointers
 updateGroups :: Filiation -> Level -> Map PhyloGroupId [Pointer] -> Phylo -> Phylo 
 updateGroups fil lvl m p = alterPhyloGroups (\gs -> map (\g -> if (getGroupLevel g) == lvl
                                                                then addPointers' fil (m ! (getGroupId g)) g
@@ -190,6 +190,33 @@ interTempoMatching fil lvl prox p = traceMatching fil lvl (getThreshold prox) sc
     --------------------------------------
 
 
+------------------------------------------------------------------------
+-- | 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) <- pointers]
+  where
+    --------------------------------------
+    pointers :: [Pointer]
+    pointers = map (\(id,v) -> (getGroupLevelParentId $ getGroupFromId id p, v)) lst
+    --------------------------------------
+
+
+transposePeriodLinks :: Level -> Phylo -> Phylo
+transposePeriodLinks lvl p = alterGroupWithLevel
+  (\g ->
+    --------------------------------------
+    let childs  = getGroupsFromIds (map fst $ getGroupLevelChilds g) p
+        ascLink = toLevelUp (concat $ map getGroupPeriodParents childs) p 
+        desLink = toLevelUp (concat $ map getGroupPeriodChilds  childs) p
+    --------------------------------------
+    in g & phylo_groupPeriodParents  %~ (++ ascLink)
+         & phylo_groupPeriodChilds   %~ (++ desLink)
+    --------------------------------------
+  ) lvl p 
+
 ----------------
 -- | Tracer | --
 ----------------

src/Gargantext/Viz/Phylo/Tools.hs

@@ -261,6 +261,11 @@ getGroupLevelParents = _phylo_groupLevelParents
 getGroupLevelParentsId :: PhyloGroup -> [PhyloGroupId]
 getGroupLevelParentsId g = map fst $ getGroupLevelParents g
 
+
+-- | To get the PhyloGroups Level Parents Ids of a PhyloGroup
+getGroupLevelParentId :: PhyloGroup -> PhyloGroupId
+getGroupLevelParentId g = (head' "getGroupLevelParentId") $ getGroupLevelParentsId g
+
 -- | To get the Meta value of a PhyloGroup
 getGroupMeta :: Text -> PhyloGroup -> Double
 getGroupMeta k g = (g ^. phylo_groupMeta) ! k
@@ -338,6 +343,10 @@ getGroups = view ( phylo_periods
 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
+
 
 -- | To get the corresponding list of PhyloGroups from a list of PhyloNodes
 getGroupsFromNodes :: [PhyloNode] -> Phylo -> [PhyloGroup]