Merge branch 'dev-phylo' into dev

bin/gargantext-adaptative-phylo/Main.hs

@@ -167,7 +167,7 @@ main = do
 
             printIOMsg "End of reconstruction, start the export"
 
-            let dot = toPhyloExport phylo
+            let dot = toPhyloExport phylo        
 
             let output = (outputPath config) 
                       <> (unpack $ phyloName config)

src/Gargantext/Viz/AdaptativePhylo.hs

@@ -57,22 +57,39 @@ data CorpusParser =
     | Csv {_csv_limit :: Int}
     deriving (Show,Generic,Eq) 
 
+data SeaElevation = 
+      Constante  
+      { _cons_start :: Double
+      , _cons_step  :: Double }
+    | Adaptative 
+      { _adap_granularity :: Double }
+    deriving (Show,Generic,Eq)
 
 data Proximity = 
       WeightedLogJaccard 
       { _wlj_sensibility   :: Double 
-      , _wlj_thresholdInit :: Double
-      , _wlj_thresholdStep :: Double }
+      -- , _wlj_thresholdInit :: Double
+      -- , _wlj_thresholdStep :: Double
+      -- | max height for sea level in temporal matching
+      -- , _wlj_elevation     :: Double
+      }
     | Hamming 
     deriving (Show,Generic,Eq) 
 
 
+data SynchronyScope = SingleBranch | SiblingBranches | AllBranches deriving (Show,Generic,Eq)
+
+data SynchronyStrategy = MergeRegularGroups | MergeAllGroups deriving (Show,Generic,Eq)
+
 data Synchrony = 
-      ByProximityThreshold 
+      ByProximityThreshold
       { _bpt_threshold :: Double 
-      , _bpt_sensibility :: Double}
+      , _bpt_sensibility :: Double
+      , _bpt_scope :: SynchronyScope
+      , _bpt_strategy :: SynchronyStrategy }
     | ByProximityDistribution
-      { _bpd_sensibility :: Double} 
+      { _bpd_sensibility :: Double
+      , _bpd_strategy :: SynchronyStrategy } 
     deriving (Show,Generic,Eq)     
 
 
@@ -84,16 +101,18 @@ data TimeUnit =
       deriving (Show,Generic,Eq) 
 
 
-data ContextualUnit = 
+data Clique = 
       Fis 
       { _fis_support :: Int
       , _fis_size    :: Int }
+    | MaxClique
+      { _mcl_size :: Int } 
       deriving (Show,Generic,Eq)      
 
 
 data Quality = 
-     Quality { _qua_relevance :: Double
-             , _qua_minBranch :: Int }
+     Quality { _qua_granularity :: Double
+             , _qua_minBranch   :: Int }
       deriving (Show,Generic,Eq)   
 
 
@@ -105,10 +124,11 @@ data Config =
             , phyloName      :: Text
             , phyloLevel     :: Int
             , phyloProximity :: Proximity
+            , seaElevation   :: SeaElevation
             , phyloSynchrony :: Synchrony
             , phyloQuality   :: Quality
             , timeUnit       :: TimeUnit
-            , contextualUnit :: ContextualUnit
+            , clique         :: Clique
             , exportLabel    :: [PhyloLabel]
             , exportSort     :: Sort
             , exportFilter   :: [Filter]  
@@ -123,11 +143,12 @@ defaultConfig =
             , corpusParser   = Csv 1000
             , phyloName      = pack "Default Phylo"
             , phyloLevel     = 2
-            , phyloProximity = WeightedLogJaccard 10 0 0.1
-            , phyloSynchrony = ByProximityDistribution 0
-            , phyloQuality   = Quality 0.1 1
+            , phyloProximity = WeightedLogJaccard 10
+            , seaElevation   = Constante 0 0.1
+            , phyloSynchrony = ByProximityThreshold 0.5 10 SiblingBranches MergeAllGroups
+            , phyloQuality   = Quality 0.6 1
             , timeUnit       = Year 3 1 5
-            , contextualUnit = Fis 1 5
+            , clique         = Fis 1 5
             , exportLabel    = [BranchLabel MostInclusive 2, GroupLabel MostEmergentInclusive 2]
             , exportSort     = ByHierarchy
             , exportFilter   = [ByBranchSize 2]  
@@ -139,10 +160,12 @@ instance FromJSON CorpusParser
 instance ToJSON CorpusParser
 instance FromJSON Proximity
 instance ToJSON Proximity
+instance FromJSON SeaElevation
+instance ToJSON SeaElevation
 instance FromJSON TimeUnit
 instance ToJSON TimeUnit
-instance FromJSON ContextualUnit
-instance ToJSON ContextualUnit
+instance FromJSON Clique
+instance ToJSON Clique
 instance FromJSON PhyloLabel
 instance ToJSON PhyloLabel
 instance FromJSON Tagger
@@ -153,6 +176,10 @@ instance FromJSON Order
 instance ToJSON Order
 instance FromJSON Filter
 instance ToJSON Filter
+instance FromJSON SynchronyScope
+instance ToJSON SynchronyScope
+instance FromJSON SynchronyStrategy
+instance ToJSON SynchronyStrategy
 instance FromJSON Synchrony
 instance ToJSON Synchrony
 instance FromJSON Quality
@@ -239,6 +266,8 @@ data Phylo =
      Phylo { _phylo_foundations :: PhyloFoundations
            , _phylo_timeCooc    :: !(Map Date Cooc)
            , _phylo_timeDocs    :: !(Map Date Double)
+           , _phylo_termFreq    :: !(Map Int Double)
+           , _phylo_groupsProxi :: !(Map (PhyloGroupId,PhyloGroupId) Double)
            , _phylo_param       :: PhyloParam
            , _phylo_periods     :: Map PhyloPeriodId PhyloPeriod
            }
@@ -310,21 +339,17 @@ data Filiation = ToParents | ToChilds deriving (Generic, Show)
 data PointerType = TemporalPointer | LevelPointer deriving (Generic, Show)                
 
 
----------------------------
--- | Frequent Item Set | --
----------------------------
-
--- | Clique : Set of ngrams cooccurring in the same Document
-type Clique   = Set Ngrams
+----------------------
+-- | Phylo Clique | --
+----------------------
 
 -- | Support : Number of Documents where a Clique occurs
 type Support  = Int
 
--- | Fis : Frequent Items Set (ie: the association between a Clique and a Support)
-data PhyloFis = PhyloFis
-  { _phyloFis_clique  :: Clique
-  , _phyloFis_support :: Support
-  , _phyloFis_period  :: (Date,Date)
+data PhyloClique = PhyloClique
+  { _phyloClique_nodes   :: Set Ngrams
+  , _phyloClique_support :: Support
+  , _phyloClique_period  :: (Date,Date)
   } deriving (Generic,NFData,Show,Eq)
 
 
@@ -356,9 +381,15 @@ data PhyloLabel =
 data PhyloBranch =
       PhyloBranch
       { _branch_id :: PhyloBranchId
-      , _branch_label   :: Text
-      , _branch_meta    :: Map Text [Double]
-      } deriving (Generic, Show)
+      , _branch_canonId  :: [Int]
+      , _branch_seaLevel :: [Double]
+      , _branch_x        :: Double
+      , _branch_y        :: Double
+      , _branch_w        :: Double
+      , _branch_t        :: Double
+      , _branch_label    :: Text
+      , _branch_meta     :: Map Text [Double]
+      } deriving (Generic, Show, Eq)
 
 data PhyloExport =
       PhyloExport
@@ -372,12 +403,13 @@ data PhyloExport =
 
 makeLenses ''Config
 makeLenses ''Proximity
+makeLenses ''SeaElevation
 makeLenses ''Quality
-makeLenses ''ContextualUnit
+makeLenses ''Clique
 makeLenses ''PhyloLabel
 makeLenses ''TimeUnit
 makeLenses ''PhyloFoundations
-makeLenses ''PhyloFis
+makeLenses ''PhyloClique
 makeLenses ''Phylo
 makeLenses ''PhyloPeriod
 makeLenses ''PhyloLevel

src/Gargantext/Viz/Phylo/PhyloExample.hs

@@ -30,7 +30,7 @@ import Gargantext.Viz.AdaptativePhylo
 import Gargantext.Viz.Phylo.PhyloTools
 import Gargantext.Viz.Phylo.PhyloMaker
 import Gargantext.Viz.Phylo.PhyloExport
-import Gargantext.Viz.Phylo.TemporalMatching (temporalMatching)
+import Gargantext.Viz.Phylo.TemporalMatching (adaptativeTemporalMatching, constanteTemporalMatching)
 import Gargantext.Viz.Phylo.SynchronicClustering (synchronicClustering)
 
 import Control.Lens
@@ -38,6 +38,9 @@ import Data.GraphViz.Types.Generalised (DotGraph)
 
 import qualified Data.Vector as Vector
 
+---------------------------------
+-- | STEP 5 | -- Export the phylo
+---------------------------------
 
 phyloExport :: IO ()
 phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot" phyloDot 
@@ -45,6 +48,10 @@ phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot"
 phyloDot :: DotGraph DotId
 phyloDot = toPhyloExport phylo2
 
+--------------------------------------------------
+-- | STEP 4 | -- Process the synchronic clustering
+--------------------------------------------------
+
 phylo2 :: Phylo
 phylo2 = synchronicClustering phylo1
 
@@ -53,17 +60,22 @@ phylo2 = synchronicClustering phylo1
 -----------------------------------------------
 
 phylo1 :: Phylo
-phylo1 = temporalMatching
-       $ appendGroups fisToGroup 1 phyloFis phyloBase
+phylo1 = case (getSeaElevation phyloBase) of 
+    Constante s g   -> constanteTemporalMatching s g 
+       $ toGroupsProxi 1
+       $ appendGroups cliqueToGroup 1 phyloClique phyloBase
+    Adaptative s    -> adaptativeTemporalMatching s
+       $ toGroupsProxi 1
+       $ appendGroups cliqueToGroup 1 phyloClique phyloBase
 
 
 ---------------------------------------------
--- | STEP 2 | -- Build the frequent items set
+-- | STEP 2 | -- Build the cliques
 ---------------------------------------------
 
 
-phyloFis :: Map (Date,Date) [PhyloFis]
-phyloFis = toPhyloFis docsByPeriods (getFisSupport $ contextualUnit config) (getFisSize $ contextualUnit config) 
+phyloClique :: Map (Date,Date) [PhyloClique]
+phyloClique = toPhyloClique phyloBase docsByPeriods
 
 
 docsByPeriods :: Map (Date,Date) [Document]
@@ -96,7 +108,7 @@ config =
     defaultConfig { phyloName  = "Cesar et Cleopatre"
                   , phyloLevel = 2
                   , exportFilter = [ByBranchSize 0]
-                  , contextualUnit = Fis 0 0 }
+                  , clique = Fis 0 0 }
 
 
 docs :: [Document]

src/Gargantext/Viz/Phylo/PhyloTools.hs

@@ -34,6 +34,7 @@ import Control.Lens hiding (Level)
 import qualified Data.Vector as Vector
 import qualified Data.List as List
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 
 ------------
 -- | Io | --
@@ -66,6 +67,7 @@ roundToStr = printf "%0.*f"
 countSup :: Double -> [Double] -> Int
 countSup s l = length $ filter (>s) l
 
+
 dropByIdx :: Int -> [a] -> [a]
 dropByIdx k l = take k l ++ drop (k+1) l
 
@@ -76,6 +78,15 @@ elemIndex' e l = case (List.elemIndex e l) of
     Just i  -> i
 
 
+commonPrefix :: Eq a => [a] -> [a] -> [a] -> [a]
+commonPrefix lst lst' acc =
+    if (null lst || null lst')
+        then acc
+        else if (head' "commonPrefix" lst == head' "commonPrefix" lst')
+                then commonPrefix (tail lst) (tail lst') (acc ++ [head' "commonPrefix" lst])
+                else acc
+
+
 ---------------------
 -- | Foundations | --
 ---------------------
@@ -162,44 +173,44 @@ keepFilled f thr l = if (null $ f thr l) && (not $ null l)
                      else f thr l
 
 
-traceClique :: Map (Date, Date) [PhyloFis] -> String
+traceClique :: Map (Date, Date) [PhyloClique] -> String
 traceClique mFis = foldl (\msg cpt -> msg <> show (countSup cpt cliques) <> " (>" <> show (cpt) <> ") "  ) "" [1..6]
     where
         --------------------------------------
         cliques :: [Double]
-        cliques = sort $ map (fromIntegral . size . _phyloFis_clique) $ concat $ elems mFis
+        cliques = sort $ map (fromIntegral . size . _phyloClique_nodes) $ concat $ elems mFis
         -------------------------------------- 
 
 
-traceSupport :: Map (Date, Date) [PhyloFis] -> String
+traceSupport :: Map (Date, Date) [PhyloClique] -> String
 traceSupport mFis = foldl (\msg cpt -> msg <> show (countSup cpt supports) <> " (>" <> show (cpt) <> ") "  ) "" [1..6]
     where
         --------------------------------------
         supports :: [Double]
-        supports = sort $ map (fromIntegral . _phyloFis_support) $ concat $ elems mFis
+        supports = sort $ map (fromIntegral . _phyloClique_support) $ concat $ elems mFis
         -------------------------------------- 
 
 
-traceFis :: [Char] -> Map (Date, Date) [PhyloFis] -> Map (Date, Date) [PhyloFis]
+traceFis :: [Char] -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
 traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map length $ elems mFis) <> "\n"
                          <> "Support : " <> (traceSupport mFis) <> "\n"
-                         <> "Clique : "  <> (traceClique mFis)  <> "\n" ) mFis
+                         <> "Nb Ngrams : "  <> (traceClique mFis)  <> "\n" ) mFis
 
 
--------------------------
--- | Contextual unit | --
--------------------------
+---------------
+-- | Clique| --
+---------------
 
 
-getFisSupport :: ContextualUnit -> Int
-getFisSupport unit = case unit of 
+getCliqueSupport :: Clique -> Int
+getCliqueSupport unit = case unit of 
     Fis s _ -> s
-    -- _       -> panic ("[ERR][Viz.Phylo.PhyloTools.getFisSupport] Only Fis has a support")
+    MaxClique _ -> 0
 
-getFisSize :: ContextualUnit -> Int
-getFisSize unit = case unit of 
+getCliqueSize :: Clique -> Int
+getCliqueSize unit = case unit of 
     Fis _ s -> s
-    -- _       -> panic ("[ERR][Viz.Phylo.PhyloTools.getFisSupport] Only Fis has a clique size")  
+    MaxClique s -> s
 
 
 --------------
@@ -227,6 +238,8 @@ sumCooc cooc cooc' = unionWith (+) cooc cooc'
 getTrace :: Cooc -> Double 
 getTrace cooc = sum $ elems $ filterWithKey (\(k,k') _ -> k == k') cooc
 
+coocToDiago :: Cooc -> Cooc
+coocToDiago cooc = filterWithKey (\(k,k') _ -> k == k') cooc
 
 -- | To build the local cooc matrix of each phylogroup
 ngramsToCooc :: [Int] -> [Cooc] -> Cooc
@@ -243,6 +256,12 @@ ngramsToCooc ngrams coocs =
 getGroupId :: PhyloGroup -> PhyloGroupId 
 getGroupId group = ((group ^. phylo_groupPeriod, group ^. phylo_groupLevel), group ^. phylo_groupIndex)
 
+idToPrd :: PhyloGroupId -> PhyloPeriodId
+idToPrd id = (fst . fst) id
+
+getGroupThr :: PhyloGroup -> Double
+getGroupThr group = last' "getGroupThr" ((group ^. phylo_groupMeta) ! "breaks")
+
 groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] ->  Map a [PhyloGroup]
 groupByField toField groups = fromListWith (++) $ map (\g -> (toField g, [g])) groups
 
@@ -255,34 +274,21 @@ getPeriodPointers fil group =
 filterProximity :: Proximity -> Double -> Double -> Bool
 filterProximity proximity thr local = 
     case proximity of
-        WeightedLogJaccard _ _ _ -> local >= thr
+        WeightedLogJaccard _ -> local >= thr
         Hamming -> undefined   
 
 getProximityName :: Proximity -> String
 getProximityName proximity =
     case proximity of
-        WeightedLogJaccard _ _ _ -> "WLJaccard"
-        Hamming -> "Hamming"
-
-getProximityInit :: Proximity -> Double
-getProximityInit proximity =
-    case proximity of
-        WeightedLogJaccard _ i _ -> i
-        Hamming -> undefined  
-
-
-getProximityStep :: Proximity -> Double
-getProximityStep proximity =
-    case proximity of
-        WeightedLogJaccard _ _ s -> s
-        Hamming -> undefined               
+        WeightedLogJaccard _ -> "WLJaccard"
+        Hamming -> "Hamming"            
 
 ---------------
 -- | Phylo | --
 ---------------
 
-addPointers :: PhyloGroup -> Filiation -> PointerType -> [Pointer] -> PhyloGroup
-addPointers group fil pty pointers = 
+addPointers :: Filiation -> PointerType -> [Pointer] -> PhyloGroup -> PhyloGroup
+addPointers fil pty pointers group = 
     case pty of 
         TemporalPointer -> case fil of 
                                 ToChilds  -> group & phylo_groupPeriodChilds  .~ pointers
@@ -310,6 +316,9 @@ getLevels phylo = nub
                        .  traverse
                        . phylo_periodLevels ) phylo
 
+getSeaElevation :: Phylo -> SeaElevation
+getSeaElevation phylo = seaElevation (getConfig phylo)
+
 
 getConfig :: Phylo -> Config
 getConfig phylo = (phylo ^. phylo_param) ^. phyloParam_config
@@ -334,6 +343,26 @@ getGroupsFromLevel lvl phylo =
                  . phylo_levelGroups ) phylo
 
 
+getGroupsFromLevelPeriods :: Level -> [PhyloPeriodId] -> Phylo -> [PhyloGroup]
+getGroupsFromLevelPeriods lvl periods phylo = 
+    elems $ view ( phylo_periods
+                 .  traverse
+                 .  filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods)
+                 . phylo_periodLevels
+                 .  traverse
+                 .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
+                 . phylo_levelGroups ) phylo    
+
+
+getGroupsFromPeriods :: Level -> Map PhyloPeriodId PhyloPeriod -> [PhyloGroup]
+getGroupsFromPeriods lvl periods = 
+    elems $ view (  traverse
+                 . phylo_periodLevels
+                 .  traverse
+                 .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
+                 . phylo_levelGroups ) periods
+
+
 updatePhyloGroups :: Level -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
 updatePhyloGroups lvl m phylo = 
     over ( phylo_periods
@@ -391,27 +420,7 @@ traceSynchronyStart phylo =
 
 getSensibility :: Proximity -> Double
 getSensibility proxi = case proxi of 
-    WeightedLogJaccard s _ _ -> s
-    Hamming -> undefined
-
-getThresholdInit :: Proximity -> Double
-getThresholdInit proxi = case proxi of 
-    WeightedLogJaccard _ t _ -> t
-    Hamming -> undefined  
-
-getThresholdStep :: Proximity -> Double
-getThresholdStep proxi = case proxi of 
-    WeightedLogJaccard _ _ s -> s
-    Hamming -> undefined  
-
-
-traceBranchMatching :: Proximity -> Double -> [PhyloGroup] -> [PhyloGroup]
-traceBranchMatching proxi thr groups = case proxi of 
-    WeightedLogJaccard _ i s -> trace (
-            roundToStr 2 thr <> " "
-         <> foldl (\acc _ -> acc <> ".") "." [(10*i),(10*i + 10*s)..(10*thr)]
-         <> " " <>  show(length groups) <> " groups"
-        ) groups 
+    WeightedLogJaccard s -> s
     Hamming -> undefined
 
 ----------------
@@ -478,4 +487,9 @@ traceMatchEnd groups =
 
 traceTemporalMatching :: [PhyloGroup] -> [PhyloGroup]
 traceTemporalMatching groups = 
-    trace ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n") groups
+    trace ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n") groups
\ No newline at end of file
+
+
+traceGroupsProxi :: Map (PhyloGroupId,PhyloGroupId) Double -> Map (PhyloGroupId,PhyloGroupId) Double
+traceGroupsProxi m = 
+    trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m
\ No newline at end of file