[MERGE]

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.6.9.5
+version:        0.0.6.9.5
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data

src/Gargantext/Core/Viz/Phylo.hs

@@ -30,8 +30,7 @@ import Control.DeepSeq (NFData)
 import Control.Lens (makeLenses)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
-import Data.Map.Strict (Map)
-import Data.Set (Set)
+import Data.Map (Map)
 import Data.Swagger
 import Data.Text   (Text, pack)
 import Data.Vector (Vector)
@@ -64,9 +63,9 @@ instance ToSchema ListParser
 data SeaElevation =
       Constante
       { _cons_start :: Double
-      , _cons_gap   :: Double }
+      , _cons_step  :: Double }
     | Adaptative
-      { _adap_steps :: Double }
+      { _adap_granularity :: Double }
     deriving (Show,Generic,Eq)
 
 instance ToSchema SeaElevation
@@ -78,8 +77,8 @@ data Proximity =
     | WeightedLogSim
       { _wls_sensibility     :: Double
       , _wls_minSharedNgrams :: Int }
-    | Hamming
-      { _hmg_sensibility     :: Double
+    | Hamming 
+      { _hmg_sensibility     :: Double 
       , _hmg_minSharedNgrams :: Int}
 
     deriving (Show,Generic,Eq)
@@ -205,7 +204,7 @@ data PhyloSubConfig =
 
 
 subConfig2config :: PhyloSubConfig -> PhyloConfig
-subConfig2config subConfig = defaultConfig { phyloProximity = WeightedLogJaccard (_sc_phyloProximity subConfig) 1
+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
@@ -307,8 +306,8 @@ instance ToSchema Software where
 
 defaultSoftware :: Software
 defaultSoftware =
-      Software { _software_name    = pack "GarganText"
-               , _software_version = pack "v5" }
+      Software { _software_name    = pack "Gargantext"
+               , _software_version = pack "v4" }
 
 
 -- | Global parameters of a Phylo
@@ -325,7 +324,7 @@ instance ToSchema PhyloParam where
 
 defaultPhyloParam :: PhyloParam
 defaultPhyloParam =
-      PhyloParam { _phyloParam_version  = pack "v3"
+      PhyloParam { _phyloParam_version  = pack "v2.adaptative"
                  , _phyloParam_software = defaultSoftware
                  , _phyloParam_config   = defaultConfig }
 
@@ -410,7 +409,8 @@ data Phylo =
            , _phylo_timeDocs     :: !(Map Date Double)
            , _phylo_termFreq     :: !(Map Int Double)
            , _phylo_lastTermFreq :: !(Map Int Double)
-           , _phylo_diaSimScan   :: Set Double
+           , _phylo_horizon      :: !(Map (PhyloGroupId,PhyloGroupId) Double)
+           , _phylo_groupsProxi  :: !(Map (PhyloGroupId,PhyloGroupId) Double)
            , _phylo_param        :: PhyloParam
            , _phylo_periods      :: Map Period PhyloPeriod
            , _phylo_quality      :: Double

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

@@ -19,7 +19,7 @@ import Data.GraphViz.Attributes.Complete hiding (EdgeType, Order)
 import Data.GraphViz.Types.Generalised (DotGraph)
 import Data.GraphViz.Types.Monadic
 import Data.List ((++), sort, nub, null, concat, sortOn, groupBy, union, (\\), (!!), init, partition, notElem, unwords, nubBy, inits, elemIndex)
-import Data.Map.Strict (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault, toList, member)
+import Data.Map (Map, fromList, empty, fromListWith, insert, (!), elems, unionWith, findWithDefault, toList, member)
 import Data.Text.Lazy (fromStrict, pack, unpack)
 import Data.Vector (Vector)
 import Debug.Trace (trace)
@@ -375,7 +375,7 @@ processSort sort' elev export = case sort' of
     ByBirthDate o -> sortByBirthDate o export
     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))
+            Adaptative _ ->  export & export_branches .~ (branchToIso $ sortByHierarchy 0 (export ^. export_branches))       
 
 -----------------
 -- | Metrics | --
@@ -546,10 +546,9 @@ processLabels labels foundations freq export =
 -- | Dynamics | --
 ------------------
 
--- utiliser & creer une Map FdtId [PhyloGroup]
--- n = index of the current term
-toDynamics :: FdtId -> [PhyloGroup] -> PhyloGroup -> Map FdtId (Date,Date) -> Double
-toDynamics n elders g m =
+
+toDynamics :: Int -> [PhyloGroup] -> PhyloGroup -> Map Int (Date,Date) -> Double
+toDynamics n parents g m =
     let prd = g ^. phylo_groupPeriod
         end = last' "dynamics" (sort $ map snd $ elems m)
     in  if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
@@ -565,18 +564,18 @@ toDynamics n elders g m =
     where
         --------------------------------------
         isNew :: Bool
-        isNew = not $ elem n $ concat $ map _phylo_groupNgrams elders
+        isNew = not $ elem n $ concat $ map _phylo_groupNgrams parents
+
 
-type FdtId = Int
 processDynamics :: [PhyloGroup] -> [PhyloGroup]
 processDynamics groups =
     map (\g ->
-        let elders = filter (\g' -> (g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
+        let parents = filter (\g' -> (g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
                                   && ((fst $ g ^. phylo_groupPeriod) > (fst $ g' ^. phylo_groupPeriod))) groups
-        in  g & phylo_groupMeta %~ insert "dynamics" (map (\n -> toDynamics n elders g mapNgrams) $ g ^. phylo_groupNgrams) ) groups
+        in  g & phylo_groupMeta %~ insert "dynamics" (map (\n -> toDynamics n parents g mapNgrams) $ g ^. phylo_groupNgrams) ) groups
     where
         --------------------------------------
-        mapNgrams :: Map FdtId (Date,Date)
+        mapNgrams :: Map Int (Date,Date)
         mapNgrams = map (\dates ->
                         let dates' = sort dates
                         in (head' "dynamics" dates', last' "dynamics" dates'))
@@ -622,7 +621,7 @@ toHorizon phylo =
                               $ concat
                               $ tracePhyloAncestors newGroups) phylo
       reBranched = fromList $ map (\g -> (getGroupId g, g)) $ concat
-                 $ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromScale scale phyloAncestor
+                 $ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevel scale phyloAncestor
    in updatePhyloGroups scale reBranched phylo
   where
     -- | 1) for each periods
@@ -637,7 +636,7 @@ toHorizon phylo =
     -- | 2) find ancestors between groups without parents
     mapGroups :: [[PhyloGroup]]
     mapGroups = map (\prd ->
-      let groups  = getGroupsFromScalePeriods scale [prd] phylo
+      let groups  = getGroupsFromLevelPeriods scale [prd] phylo
           childs  = getPreviousChildIds scale frame prd periods phylo
               -- maybe add a better filter for non isolated  ancestors
           heads   = filter (\g -> (not . null) $ (g ^. phylo_groupPeriodChilds))
@@ -661,7 +660,7 @@ toHorizon phylo =
 getPreviousChildIds :: Scale -> Int -> Period -> [Period] -> Phylo -> [PhyloGroupId]
 getPreviousChildIds lvl frame curr prds phylo =
     concat $ map ((map fst) . _phylo_groupPeriodChilds)
-           $ getGroupsFromScalePeriods lvl (getNextPeriods ToParents frame curr prds) phylo
+           $ getGroupsFromLevelPeriods lvl (getNextPeriods ToParents frame curr prds) phylo
 
 ---------------------
 -- | phyloExport | --
@@ -696,10 +695,10 @@ toPhyloExport phylo = exportToDot phylo
         --------------------------------------
         groups :: [PhyloGroup]
         groups = traceExportGroups
-               -- necessaire ?
                $ processDynamics
-               $ getGroupsFromScale (phyloScale $ getConfig phylo)
+               $ getGroupsFromLevel (phyloScale $ getConfig phylo)
                $ tracePhyloInfo phylo
+               -- \$ toHorizon phylo
 
 
 traceExportBranches :: [PhyloBranch] -> [PhyloBranch]
@@ -722,3 +721,4 @@ traceExportGroups groups = trace ("\n" <> "-- | Export "
     <> show(length groups) <> " groups and "
     <> show(length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) groups) <> " terms"
   ) groups
+

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

@@ -14,7 +14,7 @@ module Gargantext.Core.Viz.Phylo.PhyloTools where
 
 import Control.Lens hiding (Level)
 import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy, group, notElem)
-import Data.Map.Strict (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
+import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
 import Data.Set (Set, disjoint)
 import Data.String (String)
 import Data.Text (Text,unpack)
@@ -25,6 +25,7 @@ import Gargantext.Prelude
 import Prelude (floor,read)
 import Text.Printf
 import qualified Data.List as List
+import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Vector as Vector
@@ -139,7 +140,6 @@ periodsToYears periods = (Set.fromList . sort . concat)
 
 
 findBounds :: [Date] -> (Date,Date)
-findBounds [] = panic "[G.C.V.P.PhyloTools] empty dates for find bounds"
 findBounds dates =
     let dates' = sort dates
     in  (head' "findBounds" dates', last' "findBounds" dates')
@@ -387,10 +387,10 @@ getLevelParentId :: PhyloGroup -> PhyloGroupId
 getLevelParentId g = fst $ head' "getLevelParentId" $ g ^. phylo_groupScaleParents
 
 getLastLevel :: Phylo -> Scale
-getLastLevel phylo = last' "lastLevel" $ getScales phylo
+getLastLevel phylo = last' "lastLevel" $ getLevels phylo
 
-getScales :: Phylo -> [Scale]
-getScales phylo = nub
+getLevels :: Phylo -> [Scale]
+getLevels phylo = nub
                 $ map snd
                 $ keys $ view ( phylo_periods
                        .  traverse
@@ -408,7 +408,7 @@ getPhyloSeaRiseStart phylo = case (getSeaElevation phylo) of
 getPhyloSeaRiseSteps :: Phylo -> Double
 getPhyloSeaRiseSteps phylo = case (getSeaElevation phylo) of
     Constante  _ s -> s
-    Adaptative s -> s
+    Adaptative s -> s    
 
 
 getConfig :: Phylo -> PhyloConfig
@@ -431,16 +431,14 @@ getRoots phylo = (phylo ^. phylo_foundations) ^. foundations_roots
 getSources :: Phylo -> Vector Text
 getSources phylo = _sources (phylo ^. phylo_sources)
 
-
--- get the groups distributed by branches at the last scale
-phyloLastScale :: Phylo -> [[PhyloGroup]]
-phyloLastScale phylo = elems
+phyloToLastBranches :: Phylo -> [[PhyloGroup]]
+phyloToLastBranches phylo = elems
     $ fromListWith (++)
     $ map (\g -> (g ^. phylo_groupBranchId, [g]))
-    $ getGroupsFromScale (last' "byBranches" $ getScales phylo) phylo
+    $ getGroupsFromLevel (last' "byBranches" $ getLevels phylo) phylo
 
-getGroupsFromScale :: Scale -> Phylo -> [PhyloGroup]
-getGroupsFromScale lvl phylo =
+getGroupsFromLevel :: Scale -> Phylo -> [PhyloGroup]
+getGroupsFromLevel lvl phylo =
     elems $ view ( phylo_periods
                  .  traverse
                  . phylo_periodScales
@@ -449,8 +447,8 @@ getGroupsFromScale lvl phylo =
                  . phylo_scaleGroups ) phylo
 
 
-getGroupsFromScalePeriods :: Scale -> [Period] -> Phylo -> [PhyloGroup]
-getGroupsFromScalePeriods lvl periods phylo =
+getGroupsFromLevelPeriods :: Scale -> [Period] -> Phylo -> [PhyloGroup]
+getGroupsFromLevelPeriods lvl periods phylo =
     elems $ view ( phylo_periods
                  .  traverse
                  .  filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods)
@@ -496,14 +494,14 @@ updatePeriods periods' phylo =
                 ) phylo
 
 updateQuality :: Double -> Phylo -> Phylo
-updateQuality quality phylo = phylo { _phylo_quality = quality }
+updateQuality quality phylo = phylo { _phylo_quality = quality }           
 
 
 traceToPhylo :: Scale -> Phylo -> Phylo
 traceToPhylo lvl phylo =
     trace ("\n" <> "-- | End of phylo making at level " <> show (lvl) <> " with "
-                <> show (length $ getGroupsFromScale lvl phylo) <> " groups and "
-                <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale lvl phylo) <> " branches" <> "\n") phylo
+                <> show (length $ getGroupsFromLevel lvl phylo) <> " groups and "
+                <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel lvl phylo) <> " branches" <> "\n") phylo
 
 --------------------
 -- | Clustering | --
@@ -566,15 +564,15 @@ toRelatedComponents nodes edges =
 traceSynchronyEnd :: Phylo -> Phylo
 traceSynchronyEnd phylo =
     trace ( "-- | End synchronic clustering at level " <> show (getLastLevel phylo)
-                 <> " with " <> show (length $ getGroupsFromScale (getLastLevel phylo) phylo) <> " groups"
-                 <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale (getLastLevel phylo) phylo) <> " branches"
+                 <> " with " <> show (length $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " groups"
+                 <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " branches"
                  <> "\n" ) phylo
 
 traceSynchronyStart :: Phylo -> Phylo
 traceSynchronyStart phylo =
     trace ( "\n" <> "-- | Start synchronic clustering at level " <> show (getLastLevel phylo)
-                 <> " with " <> show (length $ getGroupsFromScale (getLastLevel phylo) phylo) <> " groups"
-                 <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromScale (getLastLevel phylo) phylo) <> " branches"
+                 <> " with " <> show (length $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " groups"
+                 <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " branches"
                  <> "\n" ) phylo
 
 
@@ -592,7 +590,7 @@ getMinSharedNgrams :: Proximity -> Int
 getMinSharedNgrams proxi = case proxi of
     WeightedLogJaccard _ m -> m
     WeightedLogSim     _ m -> m
-    Hamming            _ _ -> undefined
+    Hamming            _ _ -> undefined    
 
 ----------------
 -- | Branch | --
@@ -661,6 +659,6 @@ traceTemporalMatching groups =
     trace ( "\n" <> "-- | Start temporal matching for " <> show(length groups) <> " groups" <> "\n") groups
 
 
-traceGroupsProxi :: [Double] -> [Double]
-traceGroupsProxi l =
-    trace ( "\n" <> "-- | " <> show(List.length l) <> " computed pairs of groups proximity" <> "\n") l
+traceGroupsProxi :: Map (PhyloGroupId,PhyloGroupId) Double -> Map (PhyloGroupId,PhyloGroupId) Double
+traceGroupsProxi m =
+    trace ( "\n" <> "-- | " <> show(Map.size m) <> " computed pairs of groups proximity" <> "\n") m