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