add label to sha

bin/gargantext-adaptative-phylo/Main.hs

@@ -17,11 +17,13 @@ Adaptative Phylo binaries
 module Main where
 
 import Data.Aeson
-import Data.ByteString.Lazy (ByteString)
+-- import Data.ByteString.Lazy (ByteString)
 -- import Data.Maybe (isJust, fromJust)
 import Data.List  (concat, nub, isSuffixOf)
 import Data.String (String)
 import Data.Text  (Text, unwords, unpack)
+import Crypto.Hash.SHA256 (hash)
+-- import Data.Digest.Pure.SHA
 
 import Gargantext.Prelude
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
@@ -42,11 +44,13 @@ import System.Environment
 import System.Directory (listDirectory)
 import Control.Concurrent.Async (mapConcurrently)
 
+import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.Vector as Vector
 import qualified Gargantext.Core.Text.Corpus.Parsers.CSV as Csv
 
 
+
 ---------------
 -- | Tools | --
 ---------------
@@ -66,7 +70,7 @@ getFilesFromPath path = do
 
 
 -- | To read and decode a Json file
-readJson :: FilePath -> IO ByteString
+readJson :: FilePath -> IO Lazy.ByteString
 readJson path = Lazy.readFile path
 
 
@@ -124,11 +128,60 @@ fileToDocs parser path lst = do
   let patterns = buildPatterns lst
   pure $ map ( (\(y,t) -> Document y t) . filterTerms patterns) corpus
 
--- configToLabel :: Config -> Text
--- configToFile confif = label
---   where 
---     label :: Text
---     label = outputPath config
+
+-- Config time parameters to label
+timeToLabel :: Config -> [Char]
+timeToLabel config = case (timeUnit config) of
+      Year p s f -> ("time"<> "_"<> (show p) <> "_"<> (show s) <> (show f))
+
+
+seaToLabel :: Config -> [Char]
+seaToLabel config = case (seaElevation config) of
+      Constante start step   -> ("sea_cst_"  <> (show start) <> "_" <> (show step))
+      Adaptative granularity -> ("sea_adapt" <> (show granularity))
+
+
+sensToLabel :: Config -> [Char]
+sensToLabel config = case (phyloProximity config) of
+      Hamming -> undefined
+      WeightedLogJaccard s -> ("WeightedLogJaccard_"  <> show s)     
+      WeightedLogSim s -> ( "WeightedLogSim-sens_"  <> show s)
+
+
+cliqueToLabel :: Config -> [Char]
+cliqueToLabel config = case (clique config) of
+      Fis s s' -> "fis_" <> (show s) <> "_" <> (show s')
+      MaxClique s t f ->  "clique_" <> (show s)<> "_"  <> (show f)<> "_"  <> (show t)
+
+
+syncToLabel :: Config -> [Char]
+syncToLabel config = case (phyloSynchrony config) of
+      ByProximityThreshold scl sync_sens scope _ -> ("scale_" <> (show scope) <> "_" <> (show sync_sens)  <> "_"  <> (show scl))
+      ByProximityDistribution _ _ -> undefined
+
+
+-- To set up the export file's label from the configuration
+configToLabel :: Config -> [Char]
+configToLabel config = outputPath config
+                    <> (unpack $ phyloName config)
+                    <> "-" <> (timeToLabel config)
+                    <> "-scale_" <> (show (phyloLevel config))
+                    <> "-" <> (seaToLabel config)
+                    <> "-" <> (sensToLabel config)
+                    <> "-" <> (cliqueToLabel config)
+                    <> "-level_" <> (show (_qua_granularity $ phyloQuality config))
+                    <> "-" <> (syncToLabel config)
+                    <> ".dot"
+
+configToSha :: Config -> [Char]
+configToSha config = show (hash $ C8.pack label)
+  where 
+    label :: [Char]
+    label = (corpusPath    config)
+         <> (listPath      config)
+         <> (timeToLabel   config)
+         <> (cliqueToLabel config)
+         <> (sensToLabel   config)
 
 --------------
 -- | Main | --
@@ -168,37 +221,7 @@ main = do
             printIOMsg "End of reconstruction, start the export"
 
             let dot = toPhyloExport phylo 
-
-            let clq = case (clique config) of
-                        Fis s s' -> "fis_" <> (show s) <> "_" <> (show s')
-                        MaxClique s t f ->  "clique_" <> (show s)<> "_"  <> (show f)<> "_"  <> (show t) 
-
-            let sensibility = case (phyloProximity config) of
-                        Hamming -> undefined
-                        WeightedLogJaccard s -> ("WeightedLogJaccard_"  <> show s)     
-                        WeightedLogSim s -> ( "WeightedLogSim-sens_"  <> show s  ) 
-
-            let sync = case (phyloSynchrony config) of
-                        ByProximityThreshold scl sync_sens scope _ -> ("scale_" <> (show scope) <> "_" <> (show sync_sens)  <> "_"  <> (show scl)  )
-                        ByProximityDistribution _ _ -> undefined
-          
-            let time_unit = case (timeUnit config) of
-                        Year period step frame -> ("time"<> "_"<> (show period) <> "_"<> (show step) <> (show frame))
-
-            let sea_elevation = case (seaElevation config) of
-                        Constante sea_start sea_step -> ("sea_cst_" <> (show sea_start) <> "_" <> (show sea_step))
-                        Adaptative granu -> ("sea_adapt" <> (show granu))                   
-            
-
-            let output = (outputPath config) 
-                      <> (unpack $ phyloName config)
-                      <> "-" <> time_unit                      
-                      <> "-hlev_" <> (show (phyloLevel config))
-                      <> "-" <> sea_elevation
-                      <> "-" <> sensibility                      
-                      <> "-" <> clq
-                      <> "-level_" <> (show (_qua_granularity $ phyloQuality config))
-                      <> "-" <> sync
-                      <> ".dot"
+                  
+            let output = configToLabel config
 
             dotToFile output dot

package.yaml

@@ -309,31 +309,6 @@ executables:
       - unordered-containers
       - full-text-search
 
-  gargantext-phylo:
-    main: Main.hs
-    source-dirs: bin/gargantext-phylo
-    ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    - -O2
-    - -Wmissing-signatures
-    dependencies:
-      - aeson
-      - async
-      - base
-      - bytestring
-      - containers
-      - directory
-      - gargantext
-      - vector
-      - parallel
-      - cassava
-      - ini
-      - optparse-generic
-      - split
-      - unordered-containers
-
   gargantext-adaptative-phylo:
     main: Main.hs
     source-dirs: bin/gargantext-adaptative-phylo

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

@@ -65,9 +65,13 @@ toPhylo docs lst conf = trace ("# phylo1 groups " <> show(length $ getGroupsFrom
               else phylo1
         --------------------------------------
         phylo1 :: Phylo
-        phylo1 = toPhylo1 docs phyloBase
+        phylo1 = toPhylo1 phyloStep
         -- > AD to db here
         --------------------------------------
+        phyloStep :: Phylo
+        phyloStep = toFirstPhyloStep docs phyloBase
+        -- > AD to db here        
+        --------------------------------------
         phyloBase :: Phylo
         phyloBase = toPhyloBase docs lst conf
         -- > AD to db here
@@ -138,13 +142,11 @@ cliqueToGroup fis pId lvl idx coocs = PhyloGroup pId lvl idx ""
                    [] [] [] [] []
 
 
-toPhylo1 :: [Document] -> Phylo -> Phylo
-toPhylo1 docs phyloBase = case (getSeaElevation phyloBase) of 
-    Constante start gap -> constanteTemporalMatching  start gap 
-                   $ appendGroups cliqueToGroup 1 phyloClique phyloBase    
-    Adaptative steps    -> adaptativeTemporalMatching steps
-                   $ toGroupsProxi 1
-                   $ appendGroups cliqueToGroup 1 phyloClique phyloBase
+-- To build the first phylo step from docs and phyloBase
+toFirstPhyloStep :: [Document] -> Phylo -> Phylo
+toFirstPhyloStep docs phyloBase = case (getSeaElevation phyloBase) of 
+    Constante  _ _ -> appendGroups cliqueToGroup 1 phyloClique phyloBase
+    Adaptative _   -> toGroupsProxi 1 $ appendGroups cliqueToGroup 1 phyloClique phyloBase
     where
         --------------------------------------
         phyloClique :: Map (Date,Date) [PhyloClique]
@@ -152,8 +154,14 @@ toPhylo1 docs phyloBase = case (getSeaElevation phyloBase) of
         --------------------------------------
         docs' :: Map (Date,Date) [Document]
         docs' =  groupDocsByPeriodRec date (getPeriodIds phyloBase) (sortOn date docs) empty
-        -- docs' =  groupDocsByPeriod' date (getPeriodIds phyloBase) docs
-        --------------------------------------
+        --------------------------------------  
+
+
+
+toPhylo1 :: Phylo -> Phylo
+toPhylo1 phyloStep = case (getSeaElevation phyloStep) of 
+    Constante start gap -> constanteTemporalMatching  start gap phyloStep    
+    Adaptative steps    -> adaptativeTemporalMatching steps phyloStep
 
 
 ---------------------------