still refactoring

bin/gargantext-phylo/Main.hs

@@ -153,9 +153,9 @@ seaToLabel config = case (seaElevation config) of
 
 sensToLabel :: PhyloConfig -> [Char]
 sensToLabel config = case (phyloProximity config) of
-      Hamming _ -> undefined
-      WeightedLogJaccard s -> ("WeightedLogJaccard_"  <> show s)
-      WeightedLogSim s -> ( "WeightedLogSim-sens_"  <> show s)
+      Hamming _ _ -> undefined
+      WeightedLogJaccard s _ -> ("WeightedLogJaccard_"  <> show s)
+      WeightedLogSim s _ -> ( "WeightedLogSim-sens_"  <> show s)
 
 
 cliqueToLabel :: PhyloConfig -> [Char]
@@ -196,11 +196,11 @@ configToSha stage config = unpack
   where
     label :: [Char]
     label = case stage of
-      phyloWithoutLink -> (corpusPath    config)
+      BackupPhyloWithoutLink -> (corpusPath    config)
                        <> (listPath      config)
                        <> (timeToLabel   config)
                        <> (cliqueToLabel config)
-      phylo   -> (corpusPath    config)
+      BackupPhylo   -> (corpusPath    config)
                        <> (listPath      config)
                        <> (timeToLabel   config)
                        <> (cliqueToLabel config)

src/Gargantext/Core/Viz/Phylo.hs

@@ -72,24 +72,14 @@ instance ToSchema SeaElevation
 
 data Proximity =
       WeightedLogJaccard
-      { _wlj_sensibility   :: Double
-{-
-      -- , _wlj_thresholdInit :: Double
-      -- , _wlj_thresholdStep :: Double
-      -- | max height for sea level in temporal matching
-      -- , _wlj_elevation     :: Double
--}
-      }
+      { _wlj_sensibility     :: Double
+      , _wlj_minSharedNgrams :: Int }
     | WeightedLogSim
-      { _wlj_sensibility   :: Double
-{-
-      -- , _wlj_thresholdInit :: Double
-      -- , _wlj_thresholdStep :: Double
-      -- | max height for sea level in temporal matching
-      -- , _wlj_elevation     :: Double
--}
-      }
-    | Hamming { _wlj_sensibility :: Double }
+      { _wls_sensibility     :: Double
+      , _wls_minSharedNgrams :: Int }
+    | Hamming 
+      { _hmg_sensibility     :: Double 
+      , _hmg_minSharedNgrams :: Int}
 
     deriving (Show,Generic,Eq)
 
@@ -214,7 +204,7 @@ data PhyloSubConfig =
 
 
 subConfig2config :: PhyloSubConfig -> PhyloConfig
-subConfig2config subConfig = defaultConfig { phyloProximity = WeightedLogJaccard $ _sc_phyloProximity subConfig
+subConfig2config subConfig = defaultConfig { phyloProximity = WeightedLogJaccard (_sc_phyloProximity subConfig) 1 
                                            , phyloSynchrony = ByProximityThreshold (_sc_phyloSynchrony subConfig) 0 AllBranches MergeAllGroups
                                            , phyloQuality   = Quality (_sc_phyloQuality   subConfig) 1
                                            , timeUnit       = _sc_timeUnit       subConfig
@@ -232,7 +222,7 @@ defaultConfig =
             , listParser     = V4
             , phyloName      = pack "Phylo Name"
             , phyloScale     = 2
-            , phyloProximity = WeightedLogJaccard 0.5
+            , phyloProximity = WeightedLogJaccard 0.5 1
             , seaElevation   = Constante 0.1 0.1
             , findAncestors  = False
             , phyloSynchrony = ByProximityThreshold 0.5 0 AllBranches MergeAllGroups

src/Gargantext/Core/Viz/Phylo/PhyloExport.hs

@@ -222,8 +222,8 @@ exportToDot phylo export =
                      ,(toAttr (fromStrict "phyloTimeScale") $ pack $ getTimeScale phylo)
                      ,(toAttr (fromStrict "PhyloScale") $ pack $ show (_qua_granularity $ phyloQuality $ getConfig phylo))
                      ,(toAttr (fromStrict "phyloQuality") $ pack $ show (phylo ^. phylo_quality))
-                     ,(toAttr (fromStrict "phyloSeaRiseStart") $ pack $ show (_cons_start $ getSeaElevation phylo))
-                     ,(toAttr (fromStrict "phyloSeaRiseSteps") $ pack $ show (_cons_step  $ getSeaElevation phylo))
+                     ,(toAttr (fromStrict "phyloSeaRiseStart") $ pack $ show (getPhyloSeaRiseStart phylo))
+                     ,(toAttr (fromStrict "phyloSeaRiseSteps") $ pack $ show (getPhyloSeaRiseSteps phylo))
                      -- ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo))
                      ])
 
@@ -373,9 +373,9 @@ sortByBirthDate order export =
 processSort :: Sort -> SeaElevation -> PhyloExport -> PhyloExport
 processSort sort' elev export = case sort' of
     ByBirthDate o -> sortByBirthDate o export
-    ByHierarchy _ -> export & export_branches .~ (branchToIso' (_cons_start elev) (_cons_step elev)
-                       $ sortByHierarchy 0 (export ^. export_branches))
-
+    ByHierarchy _ -> case elev of
+            Constante  s s' ->  export & export_branches .~ (branchToIso' s s' $ sortByHierarchy 0 (export ^. export_branches))
+            Adaptative _ ->  export & export_branches .~ (branchToIso $ sortByHierarchy 0 (export ^. export_branches))       
 
 -----------------
 -- | Metrics | --
@@ -647,7 +647,7 @@ toHorizon phylo =
           proximity = (phyloProximity $ getConfig phylo)
           step = case getSeaElevation phylo of
             Constante  _ s -> s
-            Adaptative _ -> undefined
+            Adaptative _ -> 0
        -- in headsToAncestors nbDocs diago proximity heads groups []
        in map (\ego -> toAncestor nbDocs diago proximity step noHeads ego)
         $ headsToAncestors nbDocs diago proximity step heads []

src/Gargantext/Core/Viz/Phylo/PhyloTools.hs

@@ -334,16 +334,16 @@ getPeriodPointers fil g =
 filterProximity :: Proximity -> Double -> Double -> Bool
 filterProximity proximity thr local =
     case proximity of
-        WeightedLogJaccard _ -> local >= thr
-        WeightedLogSim     _ -> local >= thr
-        Hamming            _ -> undefined
+        WeightedLogJaccard _ _ -> local >= thr
+        WeightedLogSim     _ _ -> local >= thr
+        Hamming            _ _ -> undefined
 
 getProximityName :: Proximity -> String
 getProximityName proximity =
     case proximity of
-        WeightedLogJaccard _ -> "WLJaccard"
-        WeightedLogSim     _ -> "WeightedLogSim"
-        Hamming            _ -> "Hamming"
+        WeightedLogJaccard _ _ -> "WLJaccard"
+        WeightedLogSim     _ _ -> "WeightedLogSim"
+        Hamming            _ _ -> "Hamming"
 
 ---------------
 -- | Phylo | --
@@ -400,6 +400,17 @@ getSeaElevation :: Phylo -> SeaElevation
 getSeaElevation phylo = seaElevation (getConfig phylo)
 
 
+getPhyloSeaRiseStart :: Phylo -> Double
+getPhyloSeaRiseStart phylo = case (getSeaElevation phylo) of
+    Constante  s _ -> s
+    Adaptative _ -> 0
+
+getPhyloSeaRiseSteps :: Phylo -> Double
+getPhyloSeaRiseSteps phylo = case (getSeaElevation phylo) of
+    Constante  _ s -> s
+    Adaptative s -> s    
+
+
 getConfig :: Phylo -> PhyloConfig
 getConfig phylo = (phylo ^. phylo_param) ^. phyloParam_config
 
@@ -533,13 +544,15 @@ groupsToBranches' groups =
             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)
-    then acc ++ [groups]
+relatedComponents graph = foldl' (\branches groups ->
+    if (null branches)
+    then branches ++ [groups]
     else
-        let acc' = partition (\groups' -> disjoint (Set.fromList groups') (Set.fromList groups)) acc
-         in (fst acc') ++ [nub $ concat $ (snd acc') ++ [groups]]) [] graph
+        let branchPart = partition (\branch -> disjoint (Set.fromList branch) (Set.fromList groups)) branches
+         in (fst branchPart) ++ [nub $ concat $ (snd branchPart) ++ [groups]]) [] graph
+
 
 toRelatedComponents :: [PhyloGroup] -> [((PhyloGroup,PhyloGroup),Double)] -> [[PhyloGroup]]
 toRelatedComponents nodes edges =
@@ -569,9 +582,15 @@ traceSynchronyStart phylo =
 
 getSensibility :: Proximity -> Double
 getSensibility proxi = case proxi of
-    WeightedLogJaccard s -> s
-    WeightedLogSim     s -> s
-    Hamming            _ -> undefined
+    WeightedLogJaccard s _ -> s
+    WeightedLogSim     s _ -> s
+    Hamming            _ _ -> undefined
+
+getMinSharedNgrams :: Proximity -> Int
+getMinSharedNgrams proxi = case proxi of
+    WeightedLogJaccard _ m -> m
+    WeightedLogSim     _ m -> m
+    Hamming            _ _ -> undefined    
 
 ----------------
 -- | Branch | --

src/Gargantext/Core/Viz/Phylo/SynchronicClustering.hs

@@ -140,10 +140,10 @@ groupsToEdges prox sync nbDocs diago groups =
         toEdges :: Double -> [(PhyloGroup,PhyloGroup)] -> [((PhyloGroup,PhyloGroup),Double)]
         toEdges sens edges = 
             case prox of
-                WeightedLogJaccard _ -> map (\(g,g') -> 
+                WeightedLogJaccard _ _ -> map (\(g,g') -> 
                                                      ((g,g'), weightedLogJaccard' (sens) nbDocs diago
                                                                   (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) edges
-                WeightedLogSim _ -> map (\(g,g') -> 
+                WeightedLogSim _ _     -> map (\(g,g') -> 
                                                      ((g,g'), weightedLogJaccard' (1 / sens) nbDocs diago
                                                                   (g ^. phylo_groupNgrams) (g' ^. phylo_groupNgrams))) edges
                 

src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs

@@ -100,17 +100,17 @@ toProximity :: Double -> Map Int Double -> Proximity -> [Int] -> [Int] -> [Int]
 -- | To process the proximity between a current group and a pair of targets group using the adapted Wang et al. Similarity
 toProximity nbDocs diago proximity egoNgrams targetNgrams targetNgrams' =
   case proximity of
-    WeightedLogJaccard sens ->
+    WeightedLogJaccard sens _ ->
       let pairNgrams = if targetNgrams == targetNgrams'
                           then targetNgrams
                           else union targetNgrams targetNgrams'
        in weightedLogJaccard' sens nbDocs diago egoNgrams pairNgrams
-    WeightedLogSim sens ->
+    WeightedLogSim sens _ ->
       let pairNgrams = if targetNgrams == targetNgrams'
                           then targetNgrams
                           else union targetNgrams targetNgrams'
        in weightedLogSim' sens nbDocs diago egoNgrams pairNgrams
-    Hamming _ -> undefined
+    Hamming _ _ -> undefined
 
 ------------------------
 -- | Local Matching | --
@@ -155,7 +155,7 @@ makePairs (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs di
            {- at least on of the pair candidates should be from the last added period -}
            $ filter (\((id,_),(id',_)) -> ((fst . fst) id == lastPrd) || ((fst . fst) id' == lastPrd))
            $ filter (\((id,_),(id',_)) -> (elem id inPairs) || (elem id' inPairs)) 
-           $ listToKeys candidates
+           $ listToCombi' candidates
     where
       --------------------------------------
       inPairs :: [PhyloGroupId]
@@ -171,25 +171,6 @@ makePairs (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs di
       --------------------------------------
 
 
-makePairs' :: (PhyloGroupId,[Int]) -> [(PhyloGroupId,[Int])] -> [Period] -> [Pointer] -> Filiation -> Double -> Proximity
-           -> Map Date Double -> Map Date Cooc -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))]
-makePairs' (egoId, egoNgrams) candidates periods oldPointers fil thr prox docs diagos =
-    if (null periods)
-        then []
-        else removeOldPointers oldPointers fil thr prox lastPrd
-           {- at least on of the pair candidates should be from the last added period -}
-           $ filter (\((id,_),(id',_)) -> ((fst . fst) id == lastPrd) || ((fst . fst) id' == lastPrd))
-           $ listToKeys
-           $ filter (\(id,ngrams) ->
-                let nbDocs = (sum . elems) $ filterDocs docs    ([(fst . fst) egoId, (fst . fst) id])
-                    diago  = reduceDiagos  $ filterDiago diagos ([(fst . fst) egoId, (fst . fst) id])
-                 in (toProximity nbDocs diago prox egoNgrams egoNgrams ngrams) >= thr
-            ) candidates
-    where
-      lastPrd :: Period
-      lastPrd = findLastPeriod fil periods
-
-
 filterPointers :: Proximity -> Double -> [Pointer] -> [Pointer]
 filterPointers proxi thr pts = filter (\(_,w) -> filterProximity proxi thr w) pts
 
@@ -215,6 +196,51 @@ filterPointersByPeriod fil pts =
         ToChildsMemory  -> undefined
         ToParentsMemory -> undefined
 
+
+phyloGroupMatching' :: [[(PhyloGroupId,[Int])]] -> Filiation -> Proximity -> Map Date Double -> Map Date Cooc
+                   -> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer]
+phyloGroupMatching' candidates filiation proxi docs diagos thr oldPointers (id,ngrams) =
+        if (null $ filterPointers proxi thr oldPointers)
+          -- if no previous pointers satisfy the current threshold then let's find new pointers
+          then if null nextPointers
+            then []
+            else filterPointersByPeriod filiation
+               -- 2) keep only the best set of pointers grouped by proximity
+               $ head' "phyloGroupMatching"
+               $ groupBy (\pt pt' -> (snd . fst) pt == (snd . fst) pt')
+               -- 1) find the first time frame where at leats one pointer satisfies the proximity threshold
+               $ sortBy (comparing (Down . snd . fst)) $ head' "pointers" nextPointers
+        else oldPointers
+    where
+        nextPointers :: [[(Pointer,[Int])]]
+        nextPointers = take 1
+                 -- stop as soon as we find a time frame where at least one singleton / pair satisfies the threshold 
+                 $ dropWhile (null)
+                 -- for each time frame, process the proximity on relevant pairs of targeted groups
+                 $ scanl (\acc targets ->
+                            let periods = nub $ map (fst . fst . fst) targets
+                                lastPrd = findLastPeriod filiation periods
+                                nbdocs  = sum $ elems $ (filterDocs docs ([(fst . fst) id] ++ periods))
+                                diago   = reduceDiagos
+                                        $ filterDiago diagos ([(fst . fst) id] ++ periods)
+                                singletons = processProximity nbdocs diago $ map (\g -> (g,g)) $ filter (\g -> (fst . fst . fst) g == lastPrd) targets
+                                pairs = makePairs (id,ngrams) targets periods oldPointers filiation thr proxi docs diagos
+                            in 
+                              if (null singletons) 
+                                then acc ++ ( processProximity nbdocs diago pairs )
+                                else acc ++ singletons
+                          ) [] $ map concat $ inits candidates -- groups from [[1900],[1900,1901],[1900,1901,1902],...] 
+        -----------------------------
+        processProximity :: Double -> Map Int Double -> [((PhyloGroupId,[Int]),(PhyloGroupId,[Int]))] -> [(Pointer,[Int])]
+        processProximity nbdocs diago targets =  filterPointers' proxi thr
+                                        $ concat
+                                        $ map (\(c,c') ->
+                                            let proximity = toProximity nbdocs diago proxi ngrams (snd c) (snd c')
+                                            in if ((c == c') || (snd c == snd c'))
+                                               then [((fst c,proximity),snd c)]
+                                               else [((fst c,proximity),snd c),((fst c',proximity),snd c')] ) targets      
+
+
 phyloGroupMatching :: [[(PhyloGroupId,[Int])]] -> Filiation -> Proximity -> Map Date Double -> Map Date Cooc
                    -> Double -> [Pointer] -> (PhyloGroupId,[Int]) -> [Pointer]
 phyloGroupMatching candidates filiation proxi docs diagos thr oldPointers (id,ngrams) =
@@ -273,11 +299,11 @@ getNextPeriods fil max' pId pIds =
         ToParentsMemory -> undefined
 
 
-getCandidates :: PhyloGroup -> [[(PhyloGroupId,[Int])]] -> [[(PhyloGroupId,[Int])]]
-getCandidates ego targets = 
+getCandidates :: Int -> PhyloGroup -> [[(PhyloGroupId,[Int])]] -> [[(PhyloGroupId,[Int])]]
+getCandidates minNgrams ego targets = 
   if (length (ego ^. phylo_groupNgrams)) > 1
     then  
-      map (\groups' -> filter (\g' -> (> 1) $ length $ intersect (ego ^. phylo_groupNgrams) (snd g')) groups') targets
+      map (\groups' -> filter (\g' -> (> minNgrams) $ length $ intersect (ego ^. phylo_groupNgrams) (snd g')) groups') targets
     else 
       map (\groups' -> filter (\g' -> (not . null) $ intersect (ego ^. phylo_groupNgrams) (snd g')) groups') targets
 
@@ -300,9 +326,9 @@ matchGroupsToGroups frame periods proximity thr docs coocs groups =
             diagoChi = filterDiago (map coocToDiago coocs) ([prd] ++ periodsPar)
             --  5) match in parallel all the groups (egos) to their possible candidates
             egos  = map (\ego ->
-                      let pointersPar = phyloGroupMatching (getCandidates ego candidatesPar) ToParents proximity docsPar diagoPar
+                      let pointersPar = phyloGroupMatching' (getCandidates (getMinSharedNgrams proximity) ego candidatesPar) ToParents proximity docsPar diagoPar
                                         thr (getPeriodPointers ToParents ego) (getGroupId ego, ego ^. phylo_groupNgrams)
-                          pointersChi = phyloGroupMatching (getCandidates ego candidatesChi) ToChilds  proximity docsChi diagoChi
+                          pointersChi = phyloGroupMatching' (getCandidates (getMinSharedNgrams proximity) ego candidatesChi) ToChilds  proximity docsChi diagoChi
                                         thr (getPeriodPointers ToChilds  ego) (getGroupId ego, ego ^. phylo_groupNgrams)
                        in addPointers ToChilds  TemporalPointer pointersChi
                         $ addPointers ToParents TemporalPointer pointersPar
@@ -406,6 +432,7 @@ toPhyloQuality fdt lambda freq branches =
 -- | Constant Temporal Matching | --
 ------------------------------------
 
+-- add a branch id within each group
 groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
 groupsToBranches groups =
     {- run the related component algorithm -}
@@ -418,13 +445,14 @@ groupsToBranches groups =
         --  a supprimer
         graph' = map relatedComponents egos
         --  then run it for the all the periods
-        graph  = zip [1..]
+        branches  = zip [1..]
                $ relatedComponents $ concat (graph' `using` parList rdeepseq)
     --  update each group's branch id
-    in map (\(bId,ids) ->
-        let groups'  = map (\group -> group & phylo_groupBranchId %~ (\(lvl,lst) -> (lvl,lst ++ [bId])))
-                     $ elems $ restrictKeys groups (Set.fromList ids)
-         in groups' `using` parList rdeepseq ) graph
+    in map (\(bId,branch) ->
+                let groups'  = map (\group -> group & phylo_groupBranchId %~ (\(lvl,lst) -> (lvl,lst ++ [bId])))
+                                    $ elems $ restrictKeys groups (Set.fromList branch)
+                 in groups' `using` parList rdeepseq 
+            ) branches `using` parList rdeepseq 
 
 
 reduceFrequency :: Map Int Double -> [[PhyloGroup]] -> Map Int Double
@@ -513,7 +541,7 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1
                          (toPhyloHorizon (updateQuality (snd branches) phylo))
   where
     --  2) process the temporal matching by elevating seaLvl level
-    -- branches :: ([([groups in the same branch],should we still break the branch?)],final quality)
+    -- branches :: ([([groups in the same branch],should westill break the branch?)],final quality)
     branches :: ([([PhyloGroup],Bool)],Double)
     branches = seaLevelMatching (fromIntegral $ Vector.length $ getRoots phylo)
                                 (phyloProximity $ getConfig phylo)
@@ -527,12 +555,14 @@ constanteTemporalMatching start step phylo = updatePhyloGroups 1
                                 (getPeriodIds phylo)
                                 (phylo ^. phylo_timeDocs)
                                 (phylo ^. phylo_timeCooc)
-                                (reverse $ sortOn (length . fst) groups)
+                                (reverse $ sortOn (length . fst) initBranches)
     --  1) for each group process an initial temporal Matching
     --  here we suppose that all the groups of level 1 are part of the same big branch
-    groups :: [([PhyloGroup],Bool)]
-    groups = map (\b -> (b,(length $ nub $ map _phylo_groupPeriod b) >= (_qua_minBranch $ phyloQuality $ getConfig phylo)))
-           $ groupsToBranches $ fromList $ map (\g -> (getGroupId g, g))
+    --  the Bool param determines weither you should apply the sealevel within the branch
+    -- creer un type [PhyloGroup] <=> Branch
+    initBranches :: [([PhyloGroup],Bool)]
+    initBranches = map (\b -> (b,(length $ nub $ map _phylo_groupPeriod b) >= (_qua_minBranch $ phyloQuality $ getConfig phylo)))
+           $ groupsToBranches $ Map.fromList $ map (\g -> (getGroupId g, g))
            $ matchGroupsToGroups (getTimeFrame $ timeUnit $ getConfig phylo)
                          (getPeriodIds phylo) (phyloProximity $ getConfig phylo)
                          start
@@ -585,8 +615,8 @@ getInTupleMap m k k'
 
 
 toThreshold :: Double -> Map (PhyloGroupId,PhyloGroupId) Double -> Double
-toThreshold lvl proxiGroups =
-  let idx = ((Map.size proxiGroups) `div` (floor lvl)) - 1
+toThreshold nbSteps proxiGroups =
+  let idx = ((Map.size proxiGroups) `div` (floor nbSteps)) - 1
    in if idx >= 0
         then (sort $ elems proxiGroups) !! idx
         else 1
@@ -657,11 +687,11 @@ adaptativeSeaLevelMatching fdt proxiConf depth elevation groupsProxi lambda minB
                                       [] (head' "seaLevelMatching" branches) (tail' "seaLevelMatching" branches)
           frequency' = reduceFrequency frequency (map fst branches')
           groupsProxi' = reduceTupleMapByKeys (map (getGroupId) $ concat $ map (fst) $ filter (fst . snd) branches') groupsProxi
-          -- thr = toThreshold depth groupsProxi
+          thr =  toThreshold depth groupsProxi
        in trace("\n  " <> foldl (\acc _ -> acc <> "🌊 ") "" [0..(elevation - depth)]
                        <> " [✓ " <> show(length $ filter (fst . snd) branches') <> "(" <> show(length $ concat $ map (fst) $ filter (fst . snd) branches')
                        <> ")|✗ " <> show(length $ filter (not . fst . snd) branches') <> "(" <> show(length $ concat $ map (fst) $ filter (not . fst . snd) branches') <> ")]"
-                       <> " thr = ")
+                       <> " thr = " <> show(thr))
         $ adaptativeSeaLevelMatching fdt proxiConf (depth - 1) elevation groupsProxi' lambda minBranch frequency' frame periods docs coocs branches'