color update

src/Gargantext/Viz/AdaptativePhylo.hs

@@ -52,45 +52,53 @@ import Control.Lens (makeLenses)
 
 data CorpusParser = Wos | Csv deriving (Show,Generic,Eq) 
 
+data Proximity = WeightedLogJaccard {_sensibility :: Double} 
+               | Hamming 
+               deriving (Show,Generic,Eq) 
+
 data Config = 
-     Config { corpusPath   :: FilePath
-            , listPath     :: FilePath
-            , outputPath   :: FilePath
-            , corpusParser :: CorpusParser
-            , corpusLimit  :: Int
-            , phyloName    :: Text
-            , phyloLevel   :: Int
-            , timeUnit     :: Int
-            , timeMatching :: Int
-            , timePeriod   :: Int
-            , timeStep     :: Int
-            , fisSupport   :: Int
-            , fisSize      :: Int
-            , branchSize   :: Int  
+     Config { corpusPath     :: FilePath
+            , listPath       :: FilePath
+            , outputPath     :: FilePath
+            , corpusParser   :: CorpusParser
+            , corpusLimit    :: Int
+            , phyloName      :: Text
+            , phyloLevel     :: Int
+            , phyloProximity :: Proximity
+            , timeUnit       :: Int
+            , maxTimeMatch   :: Int
+            , timePeriod     :: Int
+            , timeStep       :: Int
+            , fisSupport     :: Int
+            , fisSize        :: Int
+            , branchSize     :: Int  
             } deriving (Show,Generic,Eq)
 
 defaultConfig :: Config
 defaultConfig = 
-     Config { corpusPath   = ""
-            , listPath     = ""
-            , outputPath   = ""
-            , corpusParser = Csv
-            , corpusLimit  = 1000
-            , phyloName    = pack "Default Phylo"
-            , phyloLevel   = 2
-            , timeUnit     = 1
-            , timeMatching = 5
-            , timePeriod   = 3
-            , timeStep     = 1
-            , fisSupport   = 2
-            , fisSize      = 4
-            , branchSize   = 3  
+     Config { corpusPath     = ""
+            , listPath       = ""
+            , outputPath     = ""
+            , corpusParser   = Csv
+            , corpusLimit    = 1000
+            , phyloName      = pack "Default Phylo"
+            , phyloLevel     = 2
+            , phyloProximity = WeightedLogJaccard 10
+            , timeUnit       = 1
+            , maxTimeMatch   = 5
+            , timePeriod     = 3
+            , timeStep       = 1
+            , fisSupport     = 2
+            , fisSize        = 4
+            , branchSize     = 3  
             }
 
 instance FromJSON Config
 instance ToJSON Config
 instance FromJSON CorpusParser
 instance ToJSON CorpusParser
+instance FromJSON Proximity
+instance ToJSON Proximity
 
 
 -- | Software parameters
@@ -223,6 +231,7 @@ data PhyloGroup =
                  , _phylo_groupIndex    :: Int
                  , _phylo_groupSupport  :: Support
                  , _phylo_groupNgrams   :: [Int]
+                 , _phylo_groupCooc     :: !(Cooc)
                  , _phylo_groupBranchId :: PhyloBranchId
                  , _phylo_groupLevelParents  :: [Pointer]
                  , _phylo_groupLevelChilds   :: [Pointer]
@@ -238,6 +247,8 @@ type Weight = Double
 -- | Pointer : A weighted pointer to a given PhyloGroup
 type Pointer = (PhyloGroupId, Weight)
 
+type Link = ((PhyloGroupId, PhyloGroupId), Weight)
+
 data Filiation = ToParents | ToChilds deriving (Generic, Show)    
 data PointerType = TemporalPointer | LevelPointer deriving (Generic, Show)                
 

src/Gargantext/Viz/Phylo/PhyloMaker.hs

@@ -16,7 +16,7 @@ Portability : POSIX
 module Gargantext.Viz.Phylo.PhyloMaker where
 
 import Data.List (concat, nub, partition, sort, (++))
-import Data.Map (Map, fromListWith, keys, unionWith, fromList, empty, toList, elems, (!))
+import Data.Map (Map, fromListWith, keys, unionWith, fromList, empty, toList, elems, (!), filterWithKey, restrictKeys)
 import Data.Set (size)
 import Data.Vector (Vector)
 
@@ -58,7 +58,7 @@ toPhylo docs lst conf = phylo1
 --------------------
 
 
-appendGroups :: (a -> PhyloPeriodId -> Level -> Int -> Vector Ngrams -> PhyloGroup) -> Level -> Map (Date,Date) [a] -> Phylo -> Phylo
+appendGroups :: (a -> PhyloPeriodId -> Level -> Int -> Vector Ngrams -> [Cooc] -> PhyloGroup) -> Level -> Map (Date,Date) [a] -> Phylo -> Phylo
 appendGroups f lvl m phylo =  trace ("\n" <> "-- | Append " <> show (length $ concat $ elems m) <> " groups to Level " <> show (lvl) <> "\n")
     $ over ( phylo_periods
            .  traverse
@@ -70,20 +70,25 @@ appendGroups f lvl m phylo =  trace ("\n" <> "-- | Append " <> show (length $ co
                                 phyloFis = m ! pId
                             in  phyloLvl 
                               & phylo_levelGroups .~ (fromList $ foldl (\groups obj ->
-                                    groups ++ [(((pId,lvl),length groups),f obj pId lvl (length groups) (getRoots phylo))] ) [] phyloFis)
+                                    groups ++ [ (((pId,lvl),length groups)
+                                              , f obj pId lvl (length groups) (getRoots phylo) 
+                                                  (elems $ restrictKeys (phylo ^. phylo_timeCooc) $ periodsToYears [pId]))
+                                              ] ) [] phyloFis)
                          else 
                             phyloLvl )
            phylo  
 
 
-fisToGroup :: PhyloFis -> PhyloPeriodId -> Level ->  Int -> Vector Ngrams -> PhyloGroup
-fisToGroup fis pId lvl idx fdt = 
-    PhyloGroup pId lvl idx
-               (fis ^. phyloFis_support)
-               (ngramsToIdx (Set.toList $ fis ^. phyloFis_clique) fdt)
-               (1,[])
-               [] [] [] []
-               Nothing
+fisToGroup :: PhyloFis -> PhyloPeriodId -> Level ->  Int -> Vector Ngrams -> [Cooc] -> PhyloGroup
+fisToGroup fis pId lvl idx fdt coocs =
+    let ngrams = ngramsToIdx (Set.toList $ fis ^. phyloFis_clique) fdt
+    in  PhyloGroup pId lvl idx
+                   (fis ^. phyloFis_support)
+                   ngrams
+                   (ngramsToCooc ngrams coocs)
+                   (1,[])
+                   [] [] [] []
+                   Nothing
 
 
 toPhylo1 :: [Document] -> Phylo -> Phylo
@@ -160,6 +165,14 @@ toPhyloFis phyloDocs support clique = traceFis "Filtered Fis"
 --------------------
 
 
+-- | To build the local cooc matrix of each phylogroup
+ngramsToCooc :: [Int] -> [Cooc] -> Cooc
+ngramsToCooc ngrams coocs =
+    let cooc  = foldl (\acc cooc' -> sumCooc acc cooc') empty coocs
+        pairs = listToKeys ngrams
+    in  filterWithKey (\k _ -> elem k pairs) cooc
+
+
 -- | To transform the docs into a time map of coocurency matrix 
 docsToCoocByYear :: [Document] -> Vector Ngrams -> Config -> Map Date Cooc
 docsToCoocByYear docs fdt conf = 

src/Gargantext/Viz/Phylo/PhyloTools.hs

@@ -19,7 +19,7 @@ module Gargantext.Viz.Phylo.PhyloTools where
 import Data.Vector (Vector, elemIndex)
 import Data.List (sort, concat, null, union, (++), tails, sortOn)
 import Data.Set (Set, size)
-import Data.Map (Map, elems, fromList, unionWith, keys, member, (!))
+import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), toList)
 import Data.String (String)
 
 import Gargantext.Prelude
@@ -156,9 +156,9 @@ listToMatrix lst = fromList $ map (\k -> (k,1)) $ listToKeys $ sort lst
 sumCooc :: Cooc -> Cooc -> Cooc
 sumCooc cooc cooc' = unionWith (+) cooc cooc'
 
----------------
--- | Phylo | --
----------------
+--------------------
+-- | PhyloGroup | --
+--------------------
 
 getGroupId :: PhyloGroup -> PhyloGroupId 
 getGroupId group = ((group ^. phylo_groupPeriod, group ^. phylo_groupLevel), group ^. phylo_groupIndex)
@@ -216,4 +216,17 @@ updatePhyloGroups lvl m phylo =
                 in 
                     if member id m 
                     then m ! id
-                    else group ) phylo
\ No newline at end of file
+                    else group ) phylo
+
+
+------------------
+-- | Pointers | --
+------------------
+
+pointersToLinks :: PhyloGroupId -> [Pointer] -> [Link]
+pointersToLinks id pointers = map (\p -> ((id,fst p),snd p)) pointers
+
+mergeLinks :: [Link] -> [Link] -> [Link]
+mergeLinks toChilds toParents = 
+    let toChilds' = fromList $ map (\((from,to),w) -> ((to,from),w)) toChilds
+    in  toList $ unionWith max (fromList toParents) toChilds' 
\ No newline at end of file

src/Gargantext/Viz/Phylo/View/Export.hs

@@ -137,9 +137,9 @@ setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHea
 
 colorFromDynamics :: Double -> H.Attribute
 colorFromDynamics d 
-  | d == 0    = H.BGColor (toColor PaleGreen) 
-  | d == 1    = H.BGColor (toColor SkyBlue)
-  | d == 2    = H.BGColor (toColor LightPink) 
+  | d == 0    = H.BGColor (toColor LightCoral)
+  | d == 1    = H.BGColor (toColor Khaki)
+  | d == 2    = H.BGColor (toColor SkyBlue)
   | otherwise = H.Color (toColor Black)