Merge remote-tracking branch 'origin/206-dev-phylo' into dev

bin/gargantext-phylo/Main.hs

@@ -254,6 +254,10 @@ main = do
             corpus  <- fileToDocs' (corpusParser config) (corpusPath config) (timeUnit config) mapList
             printIOComment (show (length corpus) <> " parsed docs from the corpus")
 
+            printIOComment (show (length $ nub $ concat $ map text corpus) <> " Size ngs_coterms")
+
+            printIOComment (show (length mapList) <> " Size ngs_terms List Map Ngrams")
+
             printIOMsg "Reconstruct the phylo"
 
             -- check the existing backup files

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

@@ -27,28 +27,33 @@ import Gargantext.API.Node.Corpus.Export (getContextNgrams)
 import Gargantext.API.Prelude (GargNoServer)
 import Gargantext.Core.Text.Context (TermList)
 import Gargantext.Core.Types (Context)
+-- import Gargantext.Core.Types.Individu (User(..))
 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, toPhyloWithoutLink)
 import Gargantext.Core.Viz.Phylo.PhyloTools  ({-printIOMsg, printIOComment,-} setConfig)
-import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
+-- import Gargantext.Database.Action.Flow (getOrMk_RootWithCorpus)
+-- import Gargantext.Database.Admin.Config (userMaster)
+-- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataPhylo(..))
+import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
 import Gargantext.Database.Admin.Types.Node (CorpusId, ContextId, PhyloId)
 import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
 import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
 import Gargantext.Database.Schema.Context
-import Gargantext.Database.Schema.Node
 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
+import Gargantext.Database.Schema.Node
 import Gargantext.Prelude
 import Prelude
+import System.FilePath ((</>))
+import System.IO.Temp (withTempDirectory)
 import System.Process      as Shell
 import qualified Data.ByteString.Lazy                    as Lazy
 import qualified Data.List as List
 import qualified Data.Map.Strict  as Map
 import qualified Data.Set  as Set
 
-
 --------------------------------------------------------------------
 getPhyloData :: PhyloId -> GargNoServer (Maybe Phylo)
 getPhyloData phyloId = do
@@ -64,30 +69,35 @@ savePhylo = undefined
 --------------------------------------------------------------------
 phylo2dot2json :: Phylo -> IO Value
 phylo2dot2json phylo = do
+  withTempDirectory "/tmp" "phylo" $ \dirPath -> do
+    let fileFrom = dirPath </> "phyloFrom.dot"
+        fileDot  = dirPath </> "phylo.dot"
+        fileToJson = dirPath </> "output.json"
 
-  let
-    file_from    = "/tmp/fromPhylo.json"
-    file_dot     = "/tmp/tmp.dot"
-    file_to_json = "/tmp/toPhylo.json"
+    dotToFile fileFrom (toPhyloExport phylo)
 
-  _ <- dotToFile file_from (toPhyloExport phylo)
-  _ <- Shell.callProcess "dot" ["-Tdot", "-o", file_dot, file_from]
-  _ <- Shell.callProcess "dot" ["-Txdot_json", "-o", file_to_json, file_dot]
+    Shell.callProcess "dot" ["-Tdot", "-o", fileDot, fileFrom]
+    Shell.callProcess "dot" ["-Txdot_json", "-o", fileToJson, fileDot]
 
-  maybeValue <- decodeFileStrict file_to_json
-  print maybeValue
-  _ <- Shell.callProcess "/bin/rm" ["-rf", file_from, file_to_json, file_dot]
+    ffrom <- readFile fileFrom
+    writeFile "/tmp/fileFrom.json" ffrom
+    fdot <- readFile fileDot
+    writeFile "/tmp/file.dot" fdot
+    fto <- readFile fileToJson
+    writeFile "/tmp/fileTo.json" fto
 
-  case maybeValue of
-    Nothing -> panic "[G.C.V.Phylo.API.phylo2dot2json] Error no file"
-    Just v  -> pure v
+    maybeValue <- decodeFileStrict fileToJson
+    print maybeValue
 
+    case maybeValue of
+      Nothing -> panic "[G.C.V.Phylo.API.phylo2dot2json] Error no file"
+      Just v  -> pure v
 
 
 flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
 flowPhyloAPI config cId = do
   (_, corpus) <- corpusIdtoDocuments (timeUnit config) cId
-  phyloWithCliques <- pure $ toPhyloWithoutLink corpus config
+  let phyloWithCliques = toPhyloWithoutLink corpus config
   -- writePhylo phyloWithCliquesFile phyloWithCliques
   pure $ toPhylo (setConfig config phyloWithCliques)
 
@@ -95,17 +105,32 @@ flowPhyloAPI config cId = do
 corpusIdtoDocuments :: TimeUnit -> CorpusId -> GargNoServer (TermList, [Document])
 corpusIdtoDocuments timeUnit corpusId = do
   docs <- selectDocNodes corpusId
+  printDebug "docs *****" (length docs)
   lId  <- defaultList corpusId
+
+{-
+  (_masterUserId, _masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus
+                                           (UserName userMaster)
+                                           (Left "")
+                                           (Nothing :: Maybe HyperdataCorpus)
+  mListId <- defaultList masterCorpusId
+  repo <- getRepo [mListId,lId]
+-}
   repo <- getRepo [lId]
+  -- ngs_terms'   <- getContextNgrams corpusId mListId MapTerm NgramsTerms repo
 
   ngs_terms    <- getContextNgrams corpusId lId MapTerm NgramsTerms repo
+  printDebug "Size ngs_coterms *****" (length ngs_terms)
+
   ngs_sources  <- getContextNgrams corpusId lId MapTerm Sources repo
+  printDebug "Size ngs_sources Map Sources *****" (length ngs_sources)
 
   termList <- getTermList lId MapTerm NgramsTerms
+  printDebug "Size ngs_terms List Map Ngrams *****" (length <$> termList)
 
   let docs'= catMaybes
            $ List.map (\doc
-                        -> context2phyloDocument timeUnit doc (ngs_terms, ngs_sources)
+                        -> context2phyloDocument timeUnit doc (ngs_terms {-<> ngs_terms'-}, ngs_sources)
                       ) docs
 
   -- printDebug "corpusIdtoDocuments" (Prelude.map date docs')
@@ -154,19 +179,15 @@ toDays y m d = fromIntegral
 
 toPhyloDate :: Int -> Int -> Int -> TimeUnit -> Date
 toPhyloDate y m d tu = case tu of
-  Year  _ _ _ -> y
-  Month _ _ _ -> toMonths (Prelude.toInteger y) m d
-  Week  _ _ _ -> div (toDays (Prelude.toInteger y) m d) 7
-  Day   _ _ _ -> toDays (Prelude.toInteger y) m d
-  _           -> panic "[G.C.V.Phylo.API] toPhyloDate"
+  Year  {} -> y
+  Month {} -> toMonths (Prelude.toInteger y) m d
+  Week  {} -> div (toDays (Prelude.toInteger y) m d) 7
+  Day   {} -> toDays (Prelude.toInteger y) m d
+  _        -> panic "[G.C.V.Phylo.API] toPhyloDate"
 
 toPhyloDate' :: Int -> Int -> Int -> TimeUnit -> Text
-toPhyloDate' y m d tu = case tu of
-  Epoch _ _ _ -> pack $ show $ posixSecondsToUTCTime $ fromIntegral y
-  Year  _ _ _ -> pack $ showGregorian $ fromGregorian (toInteger y) m d
-  Month _ _ _ -> pack $ showGregorian $ fromGregorian (toInteger y) m d
-  Week  _ _ _ -> pack $ showGregorian $ fromGregorian (toInteger y) m d
-  Day   _ _ _ -> pack $ showGregorian $ fromGregorian (toInteger y) m d
+toPhyloDate' y _m _d (Epoch {}) = pack $ show $ posixSecondsToUTCTime $ fromIntegral y
+toPhyloDate' y  m  d _          = pack $ showGregorian $ fromGregorian (toInteger y) m d
 
 -- Utils
 
@@ -186,4 +207,4 @@ readPhylo path = do
 
 -- | To read and decode a Json file
 readJson :: FilePath -> IO Lazy.ByteString
-readJson path = Lazy.readFile path
+readJson = Lazy.readFile

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

@@ -375,8 +375,8 @@ 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)) 
-            Evolving   _ ->  export & export_branches .~ (branchToIso $ sortByHierarchy 0 (export ^. export_branches)) 
+            Adaptative _ ->  export & export_branches .~ (branchToIso $ sortByHierarchy 0 (export ^. export_branches))
+            Evolving   _ ->  export & export_branches .~ (branchToIso $ sortByHierarchy 0 (export ^. export_branches))
 
 -----------------
 -- | Metrics | --
@@ -568,7 +568,7 @@ toDynamics n elders g m =
         isNew :: Bool
         isNew = not $ elem n $ concat $ map _phylo_groupNgrams elders
 
-type FdtId = Int 
+type FdtId = Int
 processDynamics :: [PhyloGroup] -> [PhyloGroup]
 processDynamics groups =
     map (\g ->
@@ -652,7 +652,7 @@ toHorizon phylo =
             Adaptative _ -> 0
             Evolving   _ -> 0
        -- in headsToAncestors nbDocs diago Similarity heads groups []
-       in map (\ego -> toAncestor nbDocs diago sim step noHeads ego)
+       in map (toAncestor nbDocs diago sim step noHeads)
         $ headsToAncestors nbDocs diago sim step heads []
       ) periods
     -- | 3) process this task concurrently
@@ -684,17 +684,18 @@ toPhyloExport phylo = exportToDot phylo
                       let seaLvl = (g ^. phylo_groupMeta) ! "seaLevels"
                           breaks = (g ^. phylo_groupMeta) ! "breaks"
                           canonId = take (round $ (last' "export" breaks) + 2) (snd $ g ^. phylo_groupBranchId)
-                       in PhyloBranch (g ^. phylo_groupBranchId)
-                                      canonId
-                                      seaLvl
-                                      0
-                                      (last' "export" (take (round $ (last' "export" breaks) + 1) seaLvl))
-                                      0
-                                      0
-                                      "" empty)
-                  $ map (\gs -> head' "export" gs)
+                       in PhyloBranch { _branch_id = g ^. phylo_groupBranchId
+                                      , _branch_canonId = canonId
+                                      , _branch_seaLevel = seaLvl
+                                      , _branch_x = 0
+                                      , _branch_y = last' "export" $ take (round $ (last' "export" breaks) + 1) seaLvl
+                                      , _branch_w = 0
+                                      , _branch_t = 0
+                                      , _branch_label = ""
+                                      , _branch_meta = empty })
+                  $ map (head' "export")
                   $ groupBy (\g g' -> g ^. phylo_groupBranchId == g' ^. phylo_groupBranchId)
-                  $ sortOn (\g -> g ^. phylo_groupBranchId) groups
+                  $ sortOn (^. phylo_groupBranchId) groups
         --------------------------------------
         groups :: [PhyloGroup]
         groups = traceExportGroups
@@ -724,4 +725,3 @@ traceExportGroups groups = trace ("\n" <> "-- | Export "
     <> show(length groups) <> " groups and "
     <> show(length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) groups) <> " terms"
   ) groups
-