issue with System.Directory

bin/gargantext-phylo/Main.hs

@@ -22,8 +22,11 @@ Phylo binaries
 
 module Main where
 
+-- import System.Directory (doesFileExist) 
+
 import Data.Aeson
 import Data.Text (Text, unwords)
+import Data.List ((++))
 import GHC.Generics
 import GHC.IO (FilePath)
 import Gargantext.Prelude
@@ -62,6 +65,7 @@ import qualified Data.ByteString.Lazy as L
 
 
 type ListPath   = FilePath
+type FisPath    = FilePath
 type CorpusPath = FilePath
 data CorpusType = Wos | Csv deriving (Show,Generic) 
 type Limit = Int
@@ -70,6 +74,7 @@ data Conf =
      Conf { corpusPath  :: CorpusPath
           , corpusType  :: CorpusType
           , listPath    :: ListPath
+          , fisPath     :: FilePath
           , outputPath  :: FilePath
           , phyloName   :: Text
           , limit       :: Limit
@@ -92,6 +97,11 @@ instance ToJSON Conf
 instance FromJSON CorpusType
 instance ToJSON CorpusType
 
+
+decoder :: P.Either a b -> b
+decoder (P.Left _) = P.error "Error"
+decoder (P.Right x) = x
+
 -- | Get the conf from a Json file
 getJson :: FilePath -> IO L.ByteString
 getJson path = L.readFile path
@@ -148,6 +158,22 @@ parse format limit path l = do
   pure $ map ( (\(y,t) -> Document y t) . filterTerms patterns) corpus
 
 
+-- -- | To parse an existing Fis file
+-- parseFis :: FisPath -> Text -> Int -> Int -> Int -> Int -> IO [PhyloFis]
+-- parseFis path name grain step support clique = do
+--   let fisPath = path <> (DT.unpack name) <> "_" <> show(grain) <> "_" <> show(step) <> "_" <> show(support) <> "_" <> show(clique) <> ".json"
+--   fisExists <- doesFileExist (path)
+--   if fisExists 
+--     then do 
+--       fis <- L.readFile fisPath
+--       pure $ decoder (eitherDecode fis :: P.Either [Char] [PhyloFis])
+--     else pure []
+
+-- writeFis :: FisPath -> Text -> Int -> Int -> Int -> Int -> DM.Map (Date,Date) [PhyloFis] -> IO ()
+-- writeFis path name grain step support clique fis = do 
+--   let fisPath = path <> (DT.unpack name) <> "_" <> show(grain) <> "_" <> show(step) <> "_" <> show(support) <> "_" <> show(clique) <> ".json"
+--   P.writeFile fisPath $ show (encode (DL.concat $ DM.elems fis)) 
+
 --------------
 -- | Main | --
 --------------
@@ -168,6 +194,10 @@ main = do
 
       corpus <- parse (corpusType conf) (limit conf) (corpusPath conf) termList
 
+      -- fis <- parseFis (fisPath conf) (phyloName conf) (timeGrain conf) (timeStep conf) (fisSupport conf) (fisClique conf)
+
+      -- let mFis  = DM.fromListWith (++) $ DL.sortOn (fst . fst) $ map (\f -> (getFisPeriod f,[f])) fis
+
       let roots = DL.nub $ DL.concat $ map text corpus
 
       putStrLn $ ("\n" <> show (length corpus) <> " parsed docs")
@@ -178,7 +208,9 @@ main = do
 
       let queryView = PhyloQueryView (viewLevel conf) Merge False 1 [BranchAge] [SizeBranch $ SBParams (minSizeBranch conf)] [BranchPeakFreq,GroupLabelCooc] (Just (ByBranchAge,Asc)) Json Flat True           
 
-      let phylo = toPhylo query corpus roots termList
+      let phylo = toPhylo query corpus roots termList DM.empty
+
+      -- writeFis (fisPath conf) (phyloName conf) (timeGrain conf) (timeStep conf) (fisSupport conf) (fisClique conf) (getPhyloFis phylo)
 
       let view  = toPhyloView queryView phylo
 

src/Gargantext/Viz/Phylo.hs

@@ -79,6 +79,7 @@ data Phylo =
            , _phylo_periods     :: [PhyloPeriod]
            , _phylo_docsByYears :: Map Date Double
            , _phylo_cooc        :: Map Date (Map (Int,Int) Double)
+           , _phylo_fis         :: Map (Date,Date) [PhyloFis]
            , _phylo_param       :: PhyloParam
            }
            deriving (Generic, Show, Eq)
@@ -202,8 +203,8 @@ type Support  = Int
 data PhyloFis = PhyloFis
   { _phyloFis_clique  :: Clique
   , _phyloFis_support :: Support
-  , _phyloFis_metrics :: Map (Int,Int) (Map Text [Double])
-  } deriving (Show)
+  , _phyloFis_period  :: (Date,Date)
+  } deriving (Generic,Show,Eq)
 
 -- | A list of clustered PhyloGroup
 type PhyloCluster = [PhyloGroup]

src/Gargantext/Viz/Phylo/API.hs

@@ -26,6 +26,7 @@ module Gargantext.Viz.Phylo.API
 
 --import Control.Monad.Reader (ask)
 import Data.Text (Text)
+import Data.Map  (empty)
 import Data.Swagger
 import Gargantext.API.Types
 import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
@@ -104,7 +105,7 @@ postPhylo _n _lId q = do
     vrs = Just ("1" :: Text)
     sft = Just (Software "Gargantext" "4")
     prm = initPhyloParam vrs sft (Just q)
-  pure (toPhyloBase q prm corpus actants termList)
+  pure (toPhyloBase q prm corpus actants termList empty)
 
 
 ------------------------------------------------------------------------
@@ -139,6 +140,7 @@ instance ToSchema LouvainParams
 instance ToSchema Metric
 instance ToSchema Order
 instance ToSchema Phylo
+instance ToSchema PhyloFis
 instance ToSchema PhyloBranch
 instance ToSchema PhyloEdge
 instance ToSchema PhyloGroup

src/Gargantext/Viz/Phylo/Aggregates/Fis.hs

@@ -17,14 +17,16 @@ Portability : POSIX
 module Gargantext.Viz.Phylo.Aggregates.Fis
   where
 
+import Control.Lens     hiding (makeLenses, both, Level)
 import Data.List        (null,concat,sort)
-import Data.Map         (Map, empty,elems)
+import Data.Map         (Map,elems,mapWithKey)
 import Data.Tuple       (fst, snd)
 import Data.Set         (size)
 import Gargantext.Prelude
 import Gargantext.Text.Metrics.FrequentItemSet  (fisWithSizePolyMap, Size(..))
 import Gargantext.Viz.Phylo
 import Gargantext.Viz.Phylo.Tools
+
 import qualified Data.Map    as Map
 import qualified Data.Set    as Set
 import qualified Data.Vector.Storable as Vector
@@ -59,8 +61,15 @@ filterFisByNested = map (\l -> let cliqueMax = filterNestedSets (head' "Fis" $ m
 
 -- | To transform a list of Documents into a Frequent Items Set 
 docsToFis :: Map (Date, Date) [Document] -> Map (Date, Date) [PhyloFis]
-docsToFis docs = map (\d -> let fs = Map.toList $ fisWithSizePolyMap (Segment 1 20) 1 (map text d)
-                            in map (\f -> PhyloFis (fst f) (snd f) empty) fs) docs
+docsToFis m = mapWithKey (\k docs -> let fs = Map.toList $ fisWithSizePolyMap (Segment 1 20) 1 (map text docs)
+                                     in map (\f -> PhyloFis (fst f) (snd f) k) fs) m
+
+
+docsToFis' :: Map (Date,Date) [Document] -> Phylo -> Phylo
+docsToFis' m p = if (null $ getPhyloFis p)
+                 then p & phylo_fis .~ mapWithKey (\k docs -> let fis = Map.toList $ fisWithSizePolyMap (Segment 1 20) 1 (map text docs)
+                                                              in map (\f -> PhyloFis (fst f) (snd f) k) fis) m
+                 else p
 
 
 -- | To process a list of Filters on top of the PhyloFis
@@ -88,7 +97,20 @@ toPhyloFis ds k s t ms fs = processFilters fs
                           $ traceFis "----\nFiltered Fis by support :\n"
                           $ filterFis k s (filterFisBySupport)
                           $ traceFis "----\nUnfiltered Fis :\n"
-                          $ docsToFis ds  
+                          $ docsToFis ds
+
+
+toPhyloFis' :: Map (Date, Date) [PhyloFis] -> Bool -> Support -> Int -> [Metric] -> [Filter] -> Map (Date, Date) [PhyloFis]
+toPhyloFis' fis k s t ms fs = processFilters fs  
+                            $ processMetrics ms
+                            $ traceFis "----\nFiltered Fis by clique size :\n"
+                            $ filterFis k t (filterFisByClique)
+                            $ traceFis "----\nFiltered Fis by nested :\n"
+                            $ filterFisByNested 
+                            $ traceFis "----\nFiltered Fis by support :\n"
+                            $ filterFis k s (filterFisBySupport)
+                            $ traceFis "----\nUnfiltered Fis :\n" fis                            
+
 
 
 -----------------

src/Gargantext/Viz/Phylo/Example.hs

@@ -31,7 +31,7 @@ module Gargantext.Viz.Phylo.Example where
 import Data.GraphViz.Types.Generalised (DotGraph)
 import Data.Text (Text)
 import Data.List        ((++), last)
-import Data.Map         (Map)
+import Data.Map         (Map,empty)
 import Data.Tuple       (fst)
 import Data.Tuple.Extra
 import Data.Vector      (Vector)
@@ -87,7 +87,7 @@ phyloQueryView = PhyloQueryView 2 Merge False 1 [BranchAge] [] [BranchPeakFreq,G
 
 
 phyloFromQuery :: Phylo
-phyloFromQuery = toPhylo (queryParser queryEx) corpus actants termList
+phyloFromQuery = toPhylo (queryParser queryEx) corpus actants termList empty
 
 -- | To do : create a request handler and a query parser
 queryParser :: [Char] -> PhyloQueryBuild
@@ -227,7 +227,7 @@ phyloDocs = corpusToDocs corpus phyloBase
 
 
 phyloBase :: Phylo
-phyloBase = initPhyloBase periods (PhyloFoundations foundationsRoots termList) nbDocs cooc defaultPhyloParam
+phyloBase = initPhyloBase periods (PhyloFoundations foundationsRoots termList) nbDocs cooc empty defaultPhyloParam
 
 cooc :: Map Date (Map (Int,Int) Double)
 cooc = docsToCooc (parseDocs foundationsRoots corpus) foundationsRoots

src/Gargantext/Viz/Phylo/LevelMaker.hs

@@ -171,11 +171,14 @@ toPhylo1 clus prox metrics filters d p = case clus of
                        $ interTempoMatching Ascendant 1 prox
                        $ setLevelLinks (0,1)
                        $ setLevelLinks (1,0)
-                       $ addPhyloLevel 1 phyloFis p
+                       $ addPhyloLevel 1 phyloFis phylo'
     where
       --------------------------------------
       phyloFis :: Map (Date, Date) [PhyloFis]
-      phyloFis = toPhyloFis d k s t metrics filters
+      phyloFis = toPhyloFis' (getPhyloFis phylo') k s t metrics filters
+      --------------------------------------
+      phylo' :: Phylo
+      phylo' = docsToFis' d p
       --------------------------------------
 
   _   -> panic "[ERR][Viz.Phylo.LevelMaker.toPhylo1] fst clustering not recognized"
@@ -188,14 +191,14 @@ toPhylo0 d p = addPhyloLevel 0 d p
 
 class PhyloMaker corpus
     where
-        toPhylo ::  PhyloQueryBuild -> corpus -> [Ngrams] -> TermList -> Phylo
-        toPhyloBase :: PhyloQueryBuild -> PhyloParam -> corpus -> [Ngrams] -> TermList -> Phylo
+        toPhylo ::  PhyloQueryBuild -> corpus -> [Ngrams] -> TermList -> Map (Date,Date) [PhyloFis] -> Phylo
+        toPhyloBase :: PhyloQueryBuild -> PhyloParam -> corpus -> [Ngrams] -> TermList -> Map (Date,Date) [PhyloFis] -> Phylo
         corpusToDocs :: corpus -> Phylo -> Map (Date,Date) [Document]
 
 instance PhyloMaker [(Date, Text)]
   where
     --------------------------------------
-    toPhylo q c roots termList = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
+    toPhylo q c roots termList fis = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
       where
         --------------------------------------
         phylo1 :: Phylo
@@ -208,10 +211,10 @@ instance PhyloMaker [(Date, Text)]
         phyloDocs = corpusToDocs c phyloBase
         --------------------------------------
         phyloBase :: Phylo
-        phyloBase = tracePhyloBase $ toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c roots termList
+        phyloBase = tracePhyloBase $ toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c roots termList fis
         --------------------------------------       
     --------------------------------------
-    toPhyloBase q p c roots termList = initPhyloBase periods foundations nbDocs cooc p
+    toPhyloBase q p c roots termList fis = initPhyloBase periods foundations nbDocs cooc fis p
       where
         --------------------------------------
         cooc :: Map Date (Map (Int,Int) Double)
@@ -234,7 +237,7 @@ instance PhyloMaker [(Date, Text)]
 instance PhyloMaker [Document]
   where
     --------------------------------------
-    toPhylo q c roots termList = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
+    toPhylo q c roots termList fis = toNthLevel (getNthLevel q) (getInterTemporalMatching q) (getNthCluster q) phylo1
       where
         --------------------------------------
         phylo1 :: Phylo
@@ -247,10 +250,10 @@ instance PhyloMaker [Document]
         phyloDocs = corpusToDocs c phyloBase
         --------------------------------------
         phyloBase :: Phylo
-        phyloBase = tracePhyloBase $ toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c roots termList
+        phyloBase = tracePhyloBase $ toPhyloBase q (initPhyloParam (Just defaultPhyloVersion) (Just defaultSoftware) (Just q)) c roots termList fis
         --------------------------------------       
     --------------------------------------
-    toPhyloBase q p c roots termList = initPhyloBase periods foundations nbDocs cooc p
+    toPhyloBase q p c roots termList fis = initPhyloBase periods foundations nbDocs cooc fis p
       where
         --------------------------------------
         cooc :: Map Date (Map (Int,Int) Double)

src/Gargantext/Viz/Phylo/Tools.hs

@@ -160,8 +160,8 @@ initFoundationsRoots :: [Ngrams] -> Vector Ngrams
 initFoundationsRoots l = Vector.fromList $ map phyloAnalyzer l
 
 -- | To init the base of a Phylo from a List of Periods and Foundations
-initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> Map Date Double  -> Map Date (Map (Int,Int) Double) -> PhyloParam -> Phylo
-initPhyloBase pds fds nbDocs cooc prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) nbDocs cooc prm
+initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> Map Date Double  -> Map Date (Map (Int,Int) Double) -> Map (Date,Date) [PhyloFis] -> PhyloParam -> Phylo
+initPhyloBase pds fds nbDocs cooc fis prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) nbDocs cooc fis prm
 
 -- | To init the param of a Phylo
 initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
@@ -180,6 +180,22 @@ getPhyloCooc :: Phylo -> Map Date (Map (Int,Int) Double)
 getPhyloCooc p = p ^. phylo_cooc
 
 
+-- | To get the PhyloParam of a Phylo
+getPhyloParams :: Phylo -> PhyloParam
+getPhyloParams = _phylo_param
+
+-- | To get the title of a Phylo
+getPhyloTitle :: Phylo -> Text
+getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
+
+-- | To get the desc of a Phylo
+getPhyloDescription :: Phylo -> Text
+getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
+
+
+getPhyloFis :: Phylo -> Map (Date,Date) [PhyloFis]
+getPhyloFis = _phylo_fis
+
 
 --------------------
 -- | PhyloRoots | --
@@ -502,14 +518,14 @@ setPhyloLevelId lvl' (PhyloLevel (id, _lvl) groups)
 getClique :: PhyloFis -> Clique
 getClique = _phyloFis_clique
 
--- | To get the metrics of a PhyloFis
-getFisMetrics :: PhyloFis -> Map (Int,Int) (Map Text [Double])
-getFisMetrics = _phyloFis_metrics
-
 -- | To get the support of a PhyloFis
 getSupport :: PhyloFis -> Support
 getSupport = _phyloFis_support
 
+-- | To get the period of a PhyloFis
+getFisPeriod :: PhyloFis -> (Date,Date)
+getFisPeriod = _phyloFis_period
+
 
 ----------------------------
 -- | PhyloNodes & Edges | --

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

@@ -153,19 +153,6 @@ toPhyloView q p = traceView
 
 
 
--- | To get the PhyloParam of a Phylo
-getPhyloParams :: Phylo -> PhyloParam
-getPhyloParams = _phylo_param
-
--- | To get the title of a Phylo
-getPhyloTitle :: Phylo -> Text
-getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
-
--- | To get the desc of a Phylo
-getPhyloDescription :: Phylo -> Text
-getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
-
-
 -----------------
 -- | Taggers | --
 -----------------

stack.yaml

@@ -50,3 +50,4 @@ extra-deps:
 - stemmer-0.5.2
 - time-units-1.0.0
 - validity-0.9.0.0 # patches-{map,class}
+- directory-1.3.1.5