refactoring after code review #1

bin/gargantext-phylo/Main.hs

@@ -38,7 +38,7 @@ import Gargantext.Core.Types.Main (ListType(..))
 import Gargantext.Core.Viz.Phylo
 import Gargantext.Core.Viz.Phylo.API.Tools
 import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
-import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloStep)
+import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloWithoutLink)
 import Gargantext.Core.Viz.Phylo.PhyloTools  (printIOMsg, printIOComment, setConfig)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
@@ -50,7 +50,7 @@ import qualified Data.Text                               as T
 import qualified Data.Vector                             as Vector
 import qualified Gargantext.Core.Text.Corpus.Parsers.CSV as Csv
 
-data PhyloStage = PhyloWithCliques | PhyloWithLinks deriving (Show)
+data Backup = BackupPhyloWithoutLink | BackupPhylo deriving (Show)
 
 ---------------
 -- | Tools | --
@@ -179,7 +179,7 @@ configToLabel :: PhyloConfig -> [Char]
 configToLabel config = outputPath config
                     <> (unpack $ phyloName config)
                     <> "-" <> (timeToLabel config)
-                    <> "-scale_" <> (show (phyloLevel config))
+                    <> "-scale_" <> (show (phyloScale config))
                     <> "-" <> (seaToLabel config)
                     <> "-" <> (sensToLabel config)
                     <> "-" <> (cliqueToLabel config)
@@ -189,18 +189,18 @@ configToLabel config = outputPath config
 
 
 -- To write a sha256 from a set of config's parameters
-configToSha :: PhyloStage -> PhyloConfig -> [Char]
+configToSha :: Backup -> PhyloConfig -> [Char]
 configToSha stage config = unpack
                          $ replace "/" "-"
                          $ T.pack (show (hash $ C8.pack label))
   where
     label :: [Char]
     label = case stage of
-      PhyloWithCliques -> (corpusPath    config)
+      phyloWithoutLink -> (corpusPath    config)
                        <> (listPath      config)
                        <> (timeToLabel   config)
                        <> (cliqueToLabel config)
-      PhyloWithLinks   -> (corpusPath    config)
+      phylo   -> (corpusPath    config)
                        <> (listPath      config)
                        <> (timeToLabel   config)
                        <> (cliqueToLabel config)
@@ -208,7 +208,7 @@ configToSha stage config = unpack
                        <> (seaToLabel    config)
                        <> (syncToLabel   config)
                        <> (qualToConfig  config)
-                       <> (show (phyloLevel config))
+                       <> (show (phyloScale config))
 
 
 readListV4 :: [Char] -> IO NgramsList
@@ -255,55 +255,38 @@ main = do
 
             printIOMsg "Reconstruct the phylo"
 
-            let phyloWithCliquesFile =  (outputPath config) <> "phyloWithCliques_" <> (configToSha PhyloWithCliques config) <> ".json"
-            let phyloWithLinksFile   =  (outputPath config) <> "phyloWithLinks_"   <> (configToSha PhyloWithLinks   config) <> ".json"
+            -- check the existing backup files
 
-            phyloWithCliquesExists <- doesFileExist phyloWithCliquesFile
-            phyloWithLinksExists   <- doesFileExist phyloWithLinksFile
+            let backupPhyloWithoutLink = (outputPath config) <> "backupPhyloWithoutLink_" <> (configToSha BackupPhyloWithoutLink config) <> ".json"
+            let backupPhylo = (outputPath config) <> "backupPhylo_"   <> (configToSha BackupPhylo config) <> ".json"
 
-            -- phyloStep <- if phyloWithCliquesExists
-            --                   then do
-            --                     printIOMsg "Reconstruct the phylo step from an existing file"
-            --                     readPhylo phyloWithCliquesFile
-            --                   else do
-            --                     printIOMsg "Reconstruct the phylo step from scratch"
-            --                     pure $ toPhyloStep corpus mapList config
+            phyloWithoutLinkExists <- doesFileExist backupPhyloWithoutLink
+            phyloExists   <- doesFileExist backupPhylo
 
-            -- writePhylo phyloWithCliquesFile phyloStep
+            -- reconstruct the phylo
 
-            -- let phylo = toPhylo (setConfig config phyloStep)
+            phylo <- if phyloExists
+                        then do
+                          printIOMsg "Reconstruct the phylo from an existing file"
+                          readPhylo backupPhylo
+                        else do
+                          if phyloWithoutLinkExists
+                            then do
+                              printIOMsg "Reconstruct the phylo from an existing file without links"
+                              phyloWithoutLink <- readPhylo backupPhyloWithoutLink
+                              writePhylo backupPhyloWithoutLink phyloWithoutLink
+                              pure $ toPhylo (setConfig config phyloWithoutLink)
+                            else do
+                              printIOMsg "Reconstruct the phylo from scratch"
+                              phyloWithoutLink <- pure $ toPhyloWithoutLink corpus mapList config
+                              writePhylo backupPhyloWithoutLink phyloWithoutLink
+                              pure $ toPhylo (setConfig config phyloWithoutLink)
 
-            phyloWithLinks <- if phyloWithLinksExists
-                                  then do
-                                    printIOMsg "Reconstruct the phylo from an existing file with intertemporal links"
-                                    readPhylo phyloWithLinksFile
-                                  else do
-                                    if phyloWithCliquesExists
-                                      then do
-                                        printIOMsg "Reconstruct the phylo from an existing file with cliques"
-                                        phyloWithCliques <- readPhylo phyloWithCliquesFile
-                                        writePhylo phyloWithCliquesFile phyloWithCliques
-                                        pure $ toPhylo (setConfig config phyloWithCliques)
-                                      else do
-                                        printIOMsg "Reconstruct the phylo from scratch"
-                                        phyloWithCliques <- pure $ toPhyloStep corpus mapList config
-                                        writePhylo phyloWithCliquesFile phyloWithCliques
-                                        pure $ toPhylo (setConfig config phyloWithCliques)
-
-            writePhylo phyloWithLinksFile phyloWithLinks
-
-
-            -- probes
-
-            -- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_synchronic_distance_cumu_jaccard.txt")
-            --          $ synchronicDistance' phylo 1
-
-            -- writeFile ((outputPath config) <> (unpack $ phyloName config) <> "_inflexion_points.txt")
-            --         $ inflexionPoints phylo 1
+            writePhylo backupPhylo phylo
 
             printIOMsg "End of reconstruction, start the export"
 
-            let dot = toPhyloExport (setConfig config phyloWithLinks)
+            let dot = toPhyloExport (setConfig config phylo)
 
             let output = configToLabel config
 

src/Gargantext/Core/Methods/Graph/MaxClique.hs

@@ -72,7 +72,7 @@ type Neighbor = Node
 -- | getMaxCliques
 -- TODO chose distance order
 
-getMaxCliques :: Ord a => CliqueFilter -> Distance -> Threshold -> Map (a, a) Int -> [[a]]
+getMaxCliques :: Ord a => MaxCliqueFilter -> Distance -> Threshold -> Map (a, a) Int -> [[a]]
 getMaxCliques f d t m = map fromIndices $ getMaxCliques' t m'
   where
     m'          = toIndex to m

src/Gargantext/Core/Viz/Phylo.hs

@@ -150,24 +150,24 @@ instance ToSchema TimeUnit where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 
 
-data CliqueFilter = ByThreshold | ByNeighbours deriving (Show,Generic,Eq)
+data MaxCliqueFilter = ByThreshold | ByNeighbours deriving (Show,Generic,Eq)
 
-instance ToSchema CliqueFilter where
+instance ToSchema MaxCliqueFilter where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 
 
 
-data Clique =
+data Cluster =
       Fis
       { _fis_support :: Int
       , _fis_size    :: Int }
     | MaxClique
       { _mcl_size      :: Int
       , _mcl_threshold :: Double
-      , _mcl_filter    :: CliqueFilter }
+      , _mcl_filter    :: MaxCliqueFilter }
       deriving (Show,Generic,Eq)
 
-instance ToSchema Clique where
+instance ToSchema Cluster where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 
 
@@ -187,14 +187,14 @@ data PhyloConfig =
             , corpusParser   :: CorpusParser
             , listParser     :: ListParser
             , phyloName      :: Text
-            , phyloLevel     :: Int
+            , phyloScale     :: Int
             , phyloProximity :: Proximity
             , seaElevation   :: SeaElevation
             , findAncestors  :: Bool
             , phyloSynchrony :: Synchrony
             , phyloQuality   :: Quality
             , timeUnit       :: TimeUnit
-            , clique         :: Clique
+            , clique         :: Cluster
             , exportLabel    :: [PhyloLabel]
             , exportSort     :: Sort
             , exportFilter   :: [Filter]
@@ -207,7 +207,7 @@ data PhyloSubConfig =
                  , _sc_phyloSynchrony :: Double
                  , _sc_phyloQuality   :: Double
                  , _sc_timeUnit       :: TimeUnit
-                 , _sc_clique         :: Clique
+                 , _sc_clique         :: Cluster
                  , _sc_exportFilter   :: Double
                  }
   deriving (Show,Generic,Eq)
@@ -231,7 +231,7 @@ defaultConfig =
             , corpusParser   = Csv 100000
             , listParser     = V4
             , phyloName      = pack "Phylo Name"
-            , phyloLevel     = 2
+            , phyloScale     = 2
             , phyloProximity = WeightedLogJaccard 0.5
             , seaElevation   = Constante 0.1 0.1
             , findAncestors  = False
@@ -269,11 +269,11 @@ instance ToJSON SeaElevation
 instance FromJSON TimeUnit
 instance ToJSON TimeUnit
 
-instance FromJSON CliqueFilter
-instance ToJSON CliqueFilter
+instance FromJSON MaxCliqueFilter
+instance ToJSON MaxCliqueFilter
 
-instance FromJSON Clique
-instance ToJSON Clique
+instance FromJSON Cluster
+instance ToJSON Cluster
 
 instance FromJSON PhyloLabel
 instance ToJSON PhyloLabel
@@ -346,6 +346,9 @@ defaultPhyloParam =
 -- | Date : a simple Integer
 type Date = Int
 
+-- | DateStr : the string version of a Date
+type DateStr = Text
+
 -- | Ngrams : a contiguous sequence of n terms
 type Ngrams = Text
 
@@ -354,7 +357,7 @@ type Ngrams = Text
 -- Export Database to Document
 data Document = Document
       { date    :: Date   -- datatype Date {unDate :: Int}
-      , date'   :: Text   -- show date
+      , date'   :: DateStr   -- show date
       , text    :: [Ngrams]
       , weight  :: Maybe Double
       , sources :: [Text]
@@ -396,6 +399,12 @@ type Cooc =  Map (Int,Int) Double
 -- | Phylomemy | --
 -------------------
 
+-- | Period : a tuple of Dates
+type Period = (Date,Date)
+
+-- | PeriodStr : a tuple of DateStr
+type PeriodStr = (DateStr,DateStr)
+
 
 -- | Phylo datatype of a phylomemy
 --  foundations : the foundations of the phylo
@@ -413,7 +422,8 @@ data Phylo =
            , _phylo_horizon      :: !(Map (PhyloGroupId,PhyloGroupId) Double)
            , _phylo_groupsProxi  :: !(Map (PhyloGroupId,PhyloGroupId) Double)
            , _phylo_param        :: PhyloParam
-           , _phylo_periods      :: Map PhyloPeriodId PhyloPeriod
+           , _phylo_periods      :: Map Period PhyloPeriod
+           , _phylo_quality      :: Double
            }
            deriving (Generic, Show, Eq)
 
@@ -421,57 +431,56 @@ instance ToSchema Phylo where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
 
 
--- | PhyloPeriodId : the id of a given period
-type PhyloPeriodId = (Date,Date)
+----------------
+-- | Period | --
+----------------
 
 -- | PhyloPeriod : steps of a phylomemy on a temporal axis
 --  id: tuple (start date, end date) of the temporal step of the phylomemy
---  levels: levels of granularity
+--  scales: scales of synchronic description
 data PhyloPeriod =
-     PhyloPeriod { _phylo_periodPeriod  :: (Date,Date)
-                 , _phylo_periodPeriod' :: (Text,Text)
-                 , _phylo_periodLevels  :: Map PhyloLevelId PhyloLevel
+     PhyloPeriod { _phylo_periodPeriod    :: Period
+                 , _phylo_periodPeriodStr :: PeriodStr
+                 , _phylo_periodScales    :: Map PhyloScaleId PhyloScale
                  } deriving (Generic, Show, Eq)
 
 instance ToSchema PhyloPeriod where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
 
+---------------
+-- | Scale | --
+---------------
 
+-- | Scale : a scale of synchronic description
+type Scale = Int
 
--- | Level : a level of clustering
-type Level = Int
-
--- | PhyloLevelId : the id of a level of clustering in a given period
-type PhyloLevelId  = (PhyloPeriodId,Level)
+-- | PhyloScaleId : the id of a scale of synchronic description
+type PhyloScaleId  = (Period,Scale)
 
--- | PhyloLevel : levels of phylomemy on a synchronic axis
--- Levels description:
--- Level 0: The foundations and the base of the phylo
--- Level 1: First level of clustering (the Fis)
--- Level [2..N]: Nth level of synchronic clustering (cluster of Fis)
-data PhyloLevel =
-     PhyloLevel { _phylo_levelPeriod  :: (Date,Date)
-                , _phylo_levelPeriod' :: (Text,Text)
-                , _phylo_levelLevel   :: Level
-                , _phylo_levelGroups  :: Map PhyloGroupId PhyloGroup
+-- | PhyloScale : sub-structure of the phylomemy in scale of synchronic description
+data PhyloScale =
+     PhyloScale { _phylo_scalePeriod    :: Period
+                , _phylo_scalePeriodStr :: PeriodStr
+                , _phylo_scaleScale     :: Scale
+                , _phylo_scaleGroups    :: Map PhyloGroupId PhyloGroup
                 }
                 deriving (Generic, Show, Eq)
 
-instance ToSchema PhyloLevel where
+instance ToSchema PhyloScale where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
 
 
-type PhyloGroupId  = (PhyloLevelId, Int)
+type PhyloGroupId  = (PhyloScaleId, Int)
 
--- | BranchId : (a level, a sequence of branch index)
+-- | BranchId : (a scale, a sequence of branch index)
 -- the sequence is a path of heritage from the most to the less specific branch
-type PhyloBranchId = (Level, [Int])
+type PhyloBranchId = (Scale, [Int])
 
--- | PhyloGroup : group of ngrams at each level and period
+-- | PhyloGroup : group of ngrams at each scale and period
 data PhyloGroup =
-      PhyloGroup { _phylo_groupPeriod   :: (Date,Date)
+      PhyloGroup { _phylo_groupPeriod   :: Period
                  , _phylo_groupPeriod'  :: (Text,Text)
-                 , _phylo_groupLevel    :: Level
+                 , _phylo_groupScale    :: Scale
                  , _phylo_groupIndex    :: Int
                  , _phylo_groupLabel    :: Text
                  , _phylo_groupSupport  :: Support
@@ -481,8 +490,8 @@ data PhyloGroup =
                  , _phylo_groupCooc     :: !(Cooc)
                  , _phylo_groupBranchId :: PhyloBranchId
                  , _phylo_groupMeta     :: Map Text [Double]
-                 , _phylo_groupLevelParents  :: [Pointer]
-                 , _phylo_groupLevelChilds   :: [Pointer]
+                 , _phylo_groupScaleParents  :: [Pointer]
+                 , _phylo_groupScaleChilds   :: [Pointer]
                  , _phylo_groupPeriodParents :: [Pointer]
                  , _phylo_groupPeriodChilds  :: [Pointer]
                  , _phylo_groupAncestors     :: [Pointer]
@@ -505,22 +514,23 @@ type Pointer = (PhyloGroupId, Weight)
 type Pointer' = (PhyloGroupId, (Thr,Weight))
 
 data Filiation = ToParents | ToChilds | ToParentsMemory | ToChildsMemory deriving (Generic, Show)
-data PointerType = TemporalPointer | LevelPointer deriving (Generic, Show)
+data PointerType = TemporalPointer | ScalePointer deriving (Generic, Show)
 
 
-----------------------
--- | Phylo Clique | --
-----------------------
+--------------------------
+-- | Phylo Clustering | --
+--------------------------
 
--- | Support : Number of Documents where a Clique occurs
+-- | Support : Number of Documents where a Cluster occurs
 type Support  = Int
 
-data PhyloClique = PhyloClique
-  { _phyloClique_nodes   :: [Int]
-  , _phyloClique_support :: Support
-  , _phyloClique_period  :: (Date,Date)
-  , _phyloClique_weight  :: Maybe Double
-  , _phyloClique_sources :: [Int]
+data Clustering = Clustering
+  { _clustering_roots   :: [Int]
+  , _clustering_support :: Support
+  , _clustering_period  :: Period
+  -- additional materials for visualization
+  , _clustering_visWeighting :: Maybe Double
+  , _clustering_visFiltering :: [Int]
   } deriving (Generic,NFData,Show,Eq)
 
 ----------------
@@ -595,14 +605,14 @@ makeLenses ''PhyloSubConfig
 makeLenses ''Proximity
 makeLenses ''SeaElevation
 makeLenses ''Quality
-makeLenses ''Clique
+makeLenses ''Cluster
 makeLenses ''PhyloLabel
 makeLenses ''TimeUnit
 makeLenses ''PhyloFoundations
-makeLenses ''PhyloClique
+makeLenses ''Clustering
 makeLenses ''Phylo
 makeLenses ''PhyloPeriod
-makeLenses ''PhyloLevel
+makeLenses ''PhyloScale
 makeLenses ''PhyloGroup
 makeLenses ''PhyloParam
 makeLenses ''PhyloExport
@@ -624,8 +634,8 @@ instance ToJSON PhyloParam
 instance FromJSON PhyloPeriod
 instance ToJSON PhyloPeriod
 
-instance FromJSON PhyloLevel
-instance ToJSON PhyloLevel
+instance FromJSON PhyloScale
+instance ToJSON PhyloScale
 
 instance FromJSON Software
 instance ToJSON Software

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

@@ -26,7 +26,7 @@ import Gargantext.Core.Types (TODO(..))
 import Gargantext.Core.Viz.LegacyPhylo
 import Gargantext.Core.Viz.Phylo (defaultConfig)
 import Gargantext.Core.Viz.Phylo.API.Tools
-import Gargantext.Core.Viz.Phylo.Example (phyloExample)
+import Gargantext.Core.Viz.Phylo.Example (phyloCleopatre)
 import Gargantext.Core.Viz.Phylo.Legacy.LegacyMain
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
@@ -99,7 +99,7 @@ getPhylo phyloId _lId _level _minSizeBranch = do
 getPhyloDataJson :: PhyloId -> GargNoServer Value
 getPhyloDataJson phyloId = do
   maybePhyloData <- getPhyloData phyloId
-  let phyloData = fromMaybe phyloExample maybePhyloData
+  let phyloData = fromMaybe phyloCleopatre maybePhyloData
   phyloJson <- liftBase $ phylo2dot2json phyloData
   pure phyloJson
 

src/Gargantext/Core/Viz/Phylo/API/Tools.hs

@@ -30,7 +30,7 @@ import Gargantext.Core.Types (Context)
 import Gargantext.Core.Types.Main (ListType(MapTerm))
 import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
 import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
-import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloStep)
+import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloWithoutLink)
 import Gargantext.Core.Viz.Phylo.PhyloTools  ({-printIOMsg, printIOComment,-} setConfig)
 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataPhylo(..))
@@ -87,7 +87,7 @@ phylo2dot2json phylo = do
 flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
 flowPhyloAPI config cId = do
   (mapList, corpus) <- corpusIdtoDocuments (timeUnit config) cId
-  phyloWithCliques <- pure $ toPhyloStep corpus mapList config
+  phyloWithCliques <- pure $ toPhyloWithoutLink corpus mapList config
   -- writePhylo phyloWithCliquesFile phyloWithCliques
   pure $ toPhylo (setConfig config phyloWithCliques)
 

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

@@ -39,27 +39,27 @@ phyloExport :: IO ()
 phyloExport = dotToFile "/home/qlobbe/data/phylo/output/cesar_cleopatre_V2.dot" phyloDot 
 
 phyloDot :: DotGraph DotId
-phyloDot = toPhyloExport phyloExample
+phyloDot = toPhyloExport phyloCleopatre
 
 --------------------------------------------------
 -- | STEP 4 | -- Process the synchronic clustering
 --------------------------------------------------
 
-phyloExample :: Phylo
-phyloExample = synchronicClustering $ toHorizon phylo1
+phyloCleopatre :: Phylo
+phyloCleopatre = synchronicClustering $ toHorizon flatPhylo
 
 -----------------------------------------------
 -- | STEP 3 | -- Build the Level 1 of the Phylo
 -----------------------------------------------
 
-phylo1 :: Phylo
-phylo1 = case (getSeaElevation phyloBase) of 
+flatPhylo :: Phylo
+flatPhylo = case (getSeaElevation emptyPhylo) of 
     Constante s g   -> constanteTemporalMatching s g 
        $ toGroupsProxi 1
-       $ appendGroups cliqueToGroup 1 phyloClique phyloBase
+       $ appendGroups clusterToGroup 1 seriesOfClustering emptyPhylo
     Adaptative s    -> adaptativeTemporalMatching s
        $ toGroupsProxi 1
-       $ appendGroups cliqueToGroup 1 phyloClique phyloBase
+       $ appendGroups clusterToGroup 1 seriesOfClustering emptyPhylo
 
 
 ---------------------------------------------
@@ -67,21 +67,21 @@ phylo1 = case (getSeaElevation phyloBase) of
 ---------------------------------------------
 
 
-phyloClique :: Map (Date,Date) [PhyloClique]
-phyloClique = toPhyloClique phyloBase docsByPeriods
+seriesOfClustering :: Map (Date,Date) [Clustering]
+seriesOfClustering = toSeriesOfClustering emptyPhylo docsByPeriods
 
 
 docsByPeriods :: Map (Date,Date) [Document]
 docsByPeriods = groupDocsByPeriod date periods docs
 
 
---------------------------------------------
--- | STEP 1 | -- Init the Base of the Phylo
---------------------------------------------
+---------------------------------
+-- | STEP 1 | -- Init the Phylo
+---------------------------------
 
 
-phyloBase :: Phylo
-phyloBase = toPhyloBase docs mapList config
+emptyPhylo :: Phylo
+emptyPhylo = initPhylo docs mapList config
 
 
 phyloCooc :: Map Date Cooc
@@ -101,7 +101,7 @@ nbDocsByYear = docsToTimeScaleNb docs
 config :: PhyloConfig
 config = 
     defaultConfig { phyloName  = "Cesar et Cleopatre"
-                  , phyloLevel = 2
+                  , phyloScale = 2
                   , exportFilter = [ByBranchSize 0]
                   , clique = MaxClique 0 15 ByNeighbours }
 

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

@@ -26,7 +26,7 @@ import Debug.Trace (trace)
 import Gargantext.Core.Viz.Phylo
 import Gargantext.Core.Viz.Phylo.PhyloTools
 import Gargantext.Core.Viz.Phylo.TemporalMatching (filterDocs, filterDiago, reduceDiagos, toProximity, getNextPeriods)
-import Gargantext.Prelude
+import Gargantext.Prelude hiding (scale)
 import Prelude (writeFile)
 import System.FilePath
 import qualified Data.GraphViz.Attributes.HTML as H
@@ -73,7 +73,7 @@ groupIdToDotId (((d,d'),lvl),idx) = (fromStrict . Text.pack) $ ("group" <> (show
 branchIdToDotId :: PhyloBranchId -> DotId
 branchIdToDotId bId = (fromStrict . Text.pack) $ ("branch" <> show (snd bId))
 
-periodIdToDotId :: PhyloPeriodId -> DotId
+periodIdToDotId :: Period -> DotId
 periodIdToDotId prd = (fromStrict . Text.pack) $ ("period" <> show (fst prd) <> show (snd prd))
 
 groupToTable :: Vector Ngrams -> PhyloGroup -> H.Label
@@ -220,7 +220,8 @@ exportToDot phylo export =
                      ,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups))
                      ,(toAttr (fromStrict "phyloSources") $ pack $ show (Vector.toList $ getSources phylo))
                      ,(toAttr (fromStrict "phyloTimeScale") $ pack $ getTimeScale phylo)
-                     ,(toAttr (fromStrict "phyloLevel") $ pack $ show (_qua_granularity $ phyloQuality $ getConfig 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 "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo))
@@ -249,7 +250,7 @@ exportToDot phylo export =
         _ <- mapM (\period ->
                 subgraph ((Str . fromStrict . Text.pack) $ ("Period" <> show (fst $ _phylo_periodPeriod period) <> show (snd $ _phylo_periodPeriod period))) $ do
                     graphAttrs [Rank SameRank]
-                    periodToDotNode (period ^. phylo_periodPeriod) (period ^. phylo_periodPeriod')
+                    periodToDotNode (period ^. phylo_periodPeriod) (period ^. phylo_periodPeriodStr)
 
                     {--  6) create a node for each group -}
                     mapM (\g -> groupToDotNode (getRoots phylo) g (toBid g (export ^. export_branches))) (filter (\g -> g ^. phylo_groupPeriod == (period ^. phylo_periodPeriod)) $ export ^. export_groups)
@@ -615,28 +616,28 @@ headsToAncestors nbDocs diago proximity step heads acc =
 toHorizon :: Phylo -> Phylo
 toHorizon phylo =
   let phyloAncestor = updatePhyloGroups
-                    level
+                    scale
                     (fromList $ map (\g -> (getGroupId g, g))
                               $ concat
                               $ tracePhyloAncestors newGroups) phylo
       reBranched = fromList $ map (\g -> (getGroupId g, g)) $ concat
-                 $ groupsToBranches $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevel level phyloAncestor
-   in updatePhyloGroups level reBranched phylo
+                 $ groupsToBranches' $ fromList $ map (\g -> (getGroupId g, g)) $ getGroupsFromLevel scale phyloAncestor
+   in updatePhyloGroups scale reBranched phylo
   where
     -- | 1) for each periods
-    periods :: [PhyloPeriodId]
+    periods :: [Period]
     periods = getPeriodIds phylo
     -- --
-    level :: Level
-    level = getLastLevel phylo
+    scale :: Scale
+    scale = getLastLevel phylo
     -- --
     frame :: Int
     frame = getTimeFrame $ timeUnit $ getConfig phylo
     -- | 2) find ancestors between groups without parents
     mapGroups :: [[PhyloGroup]]
     mapGroups = map (\prd ->
-      let groups  = getGroupsFromLevelPeriods level [prd] phylo
-          childs  = getPreviousChildIds level frame prd periods 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))
                   $ filter (\g -> null (g ^. phylo_groupPeriodParents) && (notElem (getGroupId g) childs)) groups
@@ -656,7 +657,7 @@ toHorizon phylo =
     newGroups = mapGroups `using` parList rdeepseq
     --------------------------------------
 
-getPreviousChildIds :: Level -> Int -> PhyloPeriodId -> [PhyloPeriodId] -> Phylo -> [PhyloGroupId]
+getPreviousChildIds :: Scale -> Int -> Period -> [Period] -> Phylo -> [PhyloGroupId]
 getPreviousChildIds lvl frame curr prds phylo =
     concat $ map ((map fst) . _phylo_groupPeriodChilds)
            $ getGroupsFromLevelPeriods lvl (getNextPeriods ToParents frame curr prds) phylo
@@ -695,7 +696,7 @@ toPhyloExport phylo = exportToDot phylo
         groups :: [PhyloGroup]
         groups = traceExportGroups
                $ processDynamics
-               $ getGroupsFromLevel (phyloLevel $ getConfig phylo)
+               $ getGroupsFromLevel (phyloScale $ getConfig phylo)
                $ tracePhyloInfo phylo
                -- \$ toHorizon phylo
 

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

@@ -231,41 +231,41 @@ keepFilled f thr l = if (null $ f thr l) && (not $ null l)
                      else f thr l
 
 
-traceClique :: Map (Date, Date) [PhyloClique] -> String
+traceClique :: Map (Date, Date) [Clustering] -> String
 traceClique mFis = foldl (\msg cpt -> msg <> show (countSup cpt cliques) <> " (>" <> show (cpt) <> ") "  ) "" [1..6]
     where
         --------------------------------------
         cliques :: [Double]
-        cliques = sort $ map (fromIntegral . length . _phyloClique_nodes) $ concat $ elems mFis
+        cliques = sort $ map (fromIntegral . length . _clustering_roots) $ concat $ elems mFis
         --------------------------------------
 
 
-traceSupport :: Map (Date, Date) [PhyloClique] -> String
+traceSupport :: Map (Date, Date) [Clustering] -> String
 traceSupport mFis = foldl (\msg cpt -> msg <> show (countSup cpt supports) <> " (>" <> show (cpt) <> ") "  ) "" [1..6]
     where
         --------------------------------------
         supports :: [Double]
-        supports = sort $ map (fromIntegral . _phyloClique_support) $ concat $ elems mFis
+        supports = sort $ map (fromIntegral . _clustering_support) $ concat $ elems mFis
         --------------------------------------
 
 
-traceFis :: [Char] -> Map (Date, Date) [PhyloClique] -> Map (Date, Date) [PhyloClique]
+traceFis :: [Char] -> Map (Date, Date) [Clustering] -> Map (Date, Date) [Clustering]
 traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map length $ elems mFis) <> "\n"
                          <> "Support : " <> (traceSupport mFis) <> "\n"
                          <> "Nb Ngrams : "  <> (traceClique mFis)  <> "\n" ) mFis
 
 
----------------
--- | Clique| --
----------------
+----------------
+-- | Cluster| --
+----------------
 
 
-getCliqueSupport :: Clique -> Int
+getCliqueSupport :: Cluster -> Int
 getCliqueSupport unit = case unit of
     Fis s _ -> s
     MaxClique _ _ _ -> 0
 
-getCliqueSize :: Clique -> Int
+getCliqueSize :: Cluster -> Int
 getCliqueSize unit = case unit of
     Fis _ s -> s
     MaxClique s _ _ -> s
@@ -315,9 +315,9 @@ ngramsToCooc ngrams coocs =
 --------------------
 
 getGroupId :: PhyloGroup -> PhyloGroupId
-getGroupId g = ((g ^. phylo_groupPeriod, g ^. phylo_groupLevel), g ^. phylo_groupIndex)
+getGroupId g = ((g ^. phylo_groupPeriod, g ^. phylo_groupScale), g ^. phylo_groupIndex)
 
-idToPrd :: PhyloGroupId -> PhyloPeriodId
+idToPrd :: PhyloGroupId -> Period
 idToPrd id = (fst . fst) id
 
 groupByField :: Ord a => (PhyloGroup -> a) -> [PhyloGroup] ->  Map a [PhyloGroup]
@@ -357,9 +357,9 @@ addPointers fil pty pointers g =
                                 ToParents -> g & phylo_groupPeriodParents .~ pointers
                                 ToChildsMemory  -> undefined
                                 ToParentsMemory -> undefined
-        LevelPointer    -> case fil of
-                                ToChilds  -> g & phylo_groupLevelChilds   .~ pointers
-                                ToParents -> g & phylo_groupLevelParents  .~ pointers
+        ScalePointer    -> case fil of
+                                ToChilds  -> g & phylo_groupScaleChilds   .~ pointers
+                                ToParents -> g & phylo_groupScaleParents  .~ pointers
                                 ToChildsMemory  -> undefined
                                 ToParentsMemory -> undefined
 
@@ -375,7 +375,7 @@ addMemoryPointers fil pty thr pointers g =
                                 ToParents -> undefined
                                 ToChildsMemory  -> g & phylo_groupPeriodMemoryChilds  .~ (concat [(g ^. phylo_groupPeriodMemoryChilds),(map (\pt -> toPointer' thr pt) pointers)])
                                 ToParentsMemory -> g & phylo_groupPeriodMemoryParents .~ (concat [(g ^. phylo_groupPeriodMemoryParents),(map (\pt -> toPointer' thr pt) pointers)])
-        LevelPointer    -> undefined
+        ScalePointer    -> undefined
 
 
 getPeriodIds :: Phylo -> [(Date,Date)]
@@ -384,17 +384,17 @@ getPeriodIds phylo = sortOn fst
                    $ phylo ^. phylo_periods
 
 getLevelParentId :: PhyloGroup -> PhyloGroupId
-getLevelParentId g = fst $ head' "getLevelParentId" $ g ^. phylo_groupLevelParents
+getLevelParentId g = fst $ head' "getLevelParentId" $ g ^. phylo_groupScaleParents
 
-getLastLevel :: Phylo -> Level
+getLastLevel :: Phylo -> Scale
 getLastLevel phylo = last' "lastLevel" $ getLevels phylo
 
-getLevels :: Phylo -> [Level]
+getLevels :: Phylo -> [Scale]
 getLevels phylo = nub
                 $ map snd
                 $ keys $ view ( phylo_periods
                        .  traverse
-                       . phylo_periodLevels ) phylo
+                       . phylo_periodScales ) phylo
 
 getSeaElevation :: Phylo -> SeaElevation
 getSeaElevation phylo = seaElevation (getConfig phylo)
@@ -426,44 +426,44 @@ phyloToLastBranches phylo = elems
     $ map (\g -> (g ^. phylo_groupBranchId, [g]))
     $ getGroupsFromLevel (last' "byBranches" $ getLevels phylo) phylo
 
-getGroupsFromLevel :: Level -> Phylo -> [PhyloGroup]
+getGroupsFromLevel :: Scale -> Phylo -> [PhyloGroup]
 getGroupsFromLevel lvl phylo =
     elems $ view ( phylo_periods
                  .  traverse
-                 . phylo_periodLevels
+                 . phylo_periodScales
                  .  traverse
-                 .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
-                 . phylo_levelGroups ) phylo
+                 .  filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
+                 . phylo_scaleGroups ) phylo
 
 
-getGroupsFromLevelPeriods :: Level -> [PhyloPeriodId] -> Phylo -> [PhyloGroup]
+getGroupsFromLevelPeriods :: Scale -> [Period] -> Phylo -> [PhyloGroup]
 getGroupsFromLevelPeriods lvl periods phylo =
     elems $ view ( phylo_periods
                  .  traverse
                  .  filtered (\phyloPrd -> elem (phyloPrd ^. phylo_periodPeriod) periods)
-                 . phylo_periodLevels
+                 . phylo_periodScales
                  .  traverse
-                 .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
-                 . phylo_levelGroups ) phylo
+                 .  filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
+                 . phylo_scaleGroups ) phylo
 
 
-getGroupsFromPeriods :: Level -> Map PhyloPeriodId PhyloPeriod -> [PhyloGroup]
+getGroupsFromPeriods :: Scale -> Map Period PhyloPeriod -> [PhyloGroup]
 getGroupsFromPeriods lvl periods =
     elems $ view (  traverse
-                 . phylo_periodLevels
+                 . phylo_periodScales
                  .  traverse
-                 .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
-                 . phylo_levelGroups ) periods
+                 .  filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
+                 . phylo_scaleGroups ) periods
 
 
-updatePhyloGroups :: Level -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
+updatePhyloGroups :: Scale -> Map PhyloGroupId PhyloGroup -> Phylo -> Phylo
 updatePhyloGroups lvl m phylo =
     over ( phylo_periods
          .  traverse
-         . phylo_periodLevels
+         . phylo_periodScales
          .  traverse
-         .  filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == lvl)
-         . phylo_levelGroups
+         .  filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == lvl)
+         . phylo_scaleGroups
          .  traverse
          ) (\g ->
                 let id = getGroupId g
@@ -477,13 +477,16 @@ updatePeriods periods' phylo =
     over (phylo_periods . traverse)
             (\prd ->
                 let prd' = periods' ! (prd ^. phylo_periodPeriod)
-                    lvls = map (\lvl -> lvl & phylo_levelPeriod' .~ prd') $ prd ^. phylo_periodLevels
-                 in prd & phylo_periodPeriod' .~ prd'
-                        & phylo_periodLevels  .~ lvls
+                    lvls = map (\lvl -> lvl & phylo_scalePeriodStr .~ prd') $ prd ^. phylo_periodScales
+                 in prd & phylo_periodPeriodStr .~ prd'
+                        & phylo_periodScales    .~ lvls
                 ) phylo
 
+updateQuality :: Double -> Phylo -> Phylo
+updateQuality quality phylo = phylo { _phylo_quality = quality }           
+
 
-traceToPhylo :: Level -> Phylo -> Phylo
+traceToPhylo :: Scale -> Phylo -> Phylo
 traceToPhylo lvl phylo =
     trace ("\n" <> "-- | End of phylo making at level " <> show (lvl) <> " with "
                 <> show (length $ getGroupsFromLevel lvl phylo) <> " groups and "
@@ -516,8 +519,8 @@ mergeMeta bId groups =
    in fromList [("breaks",(ego ^. phylo_groupMeta) ! "breaks"),("seaLevels",(ego ^. phylo_groupMeta) ! "seaLevels")]
 
 
-groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
-groupsToBranches groups =
+groupsToBranches' :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
+groupsToBranches' groups =
     {- run the related component algorithm -}
     let egos  = map (\g -> [getGroupId g]
                         ++ (map fst $ g ^. phylo_groupPeriodParents)

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

@@ -60,19 +60,19 @@ mergeGroups coocs id mapIds childs =
         mergeAncestors :: [Pointer] -> [Pointer]
         mergeAncestors pointers = Map.toList $ fromListWith max pointers
 
-addPhyloLevel :: Level -> Phylo -> Phylo
-addPhyloLevel lvl phylo = 
+addPhyloScale :: Scale -> Phylo -> Phylo
+addPhyloScale lvl phylo = 
   over ( phylo_periods .  traverse ) 
-       (\phyloPrd -> phyloPrd & phylo_periodLevels 
+       (\phyloPrd -> phyloPrd & phylo_periodScales 
                         %~ (insert (phyloPrd ^. phylo_periodPeriod, lvl) 
-                                   (PhyloLevel (phyloPrd ^. phylo_periodPeriod) (phyloPrd ^. phylo_periodPeriod') lvl empty))) phylo
+                                   (PhyloScale (phyloPrd ^. phylo_periodPeriod) (phyloPrd ^. phylo_periodPeriodStr) lvl empty))) phylo
 
 
-toNextLevel' :: Phylo -> [PhyloGroup] -> Phylo
-toNextLevel' phylo groups =
+toNextScale :: Phylo -> [PhyloGroup] -> Phylo
+toNextScale phylo groups =
     let curLvl = getLastLevel phylo
         oldGroups = fromList $ map (\g -> (getGroupId g, getLevelParentId g)) groups
-        newGroups = concat $ groupsToBranches
+        newGroups = concat $ groupsToBranches'
                   $ fromList $ map (\g -> (getGroupId g, g))
                   $ foldlWithKey (\acc id groups' ->
                         --  4) create the parent group
@@ -83,17 +83,17 @@ toNextLevel' phylo groups =
 
         newPeriods = fromListWith (++) $ map (\g -> (g ^. phylo_groupPeriod, [g])) newGroups
     in  traceSynchronyEnd 
-      $ over ( phylo_periods . traverse . phylo_periodLevels . traverse
+      $ over ( phylo_periods . traverse . phylo_periodScales . traverse
              --  6) update each period at curLvl + 1
-             . filtered (\phyloLvl -> phyloLvl ^. phylo_levelLevel == (curLvl + 1)))
+             . filtered (\phyloLvl -> phyloLvl ^. phylo_scaleScale == (curLvl + 1)))
              --  7) by adding the parents
              (\phyloLvl -> 
-                if member (phyloLvl ^. phylo_levelPeriod) newPeriods
-                    then phyloLvl & phylo_levelGroups
-                            .~ fromList (map (\g -> (getGroupId g, g)) $ newPeriods ! (phyloLvl ^. phylo_levelPeriod))
+                if member (phyloLvl ^. phylo_scalePeriod) newPeriods
+                    then phyloLvl & phylo_scaleGroups
+                            .~ fromList (map (\g -> (getGroupId g, g)) $ newPeriods ! (phyloLvl ^. phylo_scalePeriod))
                     else phyloLvl)
-      --  2) add the curLvl + 1 phyloLevel to the phylo
-      $ addPhyloLevel (curLvl + 1)
+      --  2) add the curLvl + 1 PhyloScale to the phylo
+      $ addPhyloScale (curLvl + 1)
       --  1) update the current groups (with level parent pointers) in the phylo
       $ updatePhyloGroups curLvl (fromList $ map (\g -> (getGroupId g, g)) groups) phylo 
 
@@ -150,7 +150,7 @@ groupsToEdges prox sync nbDocs diago groups =
                 _ -> undefined  
 
 toParentId :: PhyloGroup -> PhyloGroupId
-toParentId child = ((child ^. phylo_groupPeriod, child ^. phylo_groupLevel + 1), child ^. phylo_groupIndex) 
+toParentId child = ((child ^. phylo_groupPeriod, child ^. phylo_groupScale + 1), child ^. phylo_groupIndex) 
 
 
 reduceGroups :: Proximity -> Synchrony -> Map Date Double -> Map Date Cooc -> [PhyloGroup] -> [PhyloGroup]
@@ -166,7 +166,7 @@ reduceGroups prox sync docs diagos branch =
              in map (\comp -> 
                     --  4) add to each groups their futur level parent group
                     let parentId = toParentId (head' "parentId" comp)
-                    in  map (\g -> g & phylo_groupLevelParents %~ (++ [(parentId,1)]) ) comp )
+                    in  map (\g -> g & phylo_groupScaleParents %~ (++ [(parentId,1)]) ) comp )
                 -- 3) reduce the graph a a set of related components
               $ toRelatedComponents groups edges) periods 
 
@@ -185,7 +185,7 @@ adjustClustering sync branches = case sync of
 levelUpAncestors :: [PhyloGroup] -> [PhyloGroup]
 levelUpAncestors groups =
   -- 1) create an associative map of (old,new) ids
-  let ids' = fromList $ map (\g -> (getGroupId g, fst $ head' "levelUpAncestors" ( g ^. phylo_groupLevelParents))) groups 
+  let ids' = fromList $ map (\g -> (getGroupId g, fst $ head' "levelUpAncestors" ( g ^. phylo_groupScaleParents))) groups 
    in map (\g -> 
         let id' = ids' ! (getGroupId g)
             ancestors  = g ^. phylo_groupAncestors
@@ -206,7 +206,7 @@ synchronicClustering phylo =
                      $ phyloToLastBranches 
                      $ traceSynchronyStart phylo
         newBranches' = newBranches `using` parList rdeepseq
-     in toNextLevel' phylo $ levelUpAncestors $ concat newBranches'
+     in toNextScale phylo $ levelUpAncestors $ concat newBranches'
 
 
 -- synchronicDistance :: Phylo -> Level -> String