diff --git a/src/Gargantext/Core/Viz/Phylo/API/Tools.hs b/src/Gargantext/Core/Viz/Phylo/API/Tools.hs index 7fc9184ab806661e9ed685c71153fceec256476c..7db9e15fb2515b44672e6d05afed667da6e96cca 100644 --- a/src/Gargantext/Core/Viz/Phylo/API/Tools.hs +++ b/src/Gargantext/Core/Viz/Phylo/API/Tools.hs @@ -46,6 +46,8 @@ 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 @@ -67,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) @@ -172,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 @@ -204,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 diff --git a/src/Gargantext/Core/Viz/Phylo/PhyloExport.hs b/src/Gargantext/Core/Viz/Phylo/PhyloExport.hs index 3f81d56918fdd8844e1e7b1a859032992e3f8301..c7f4aa3ac76a250ab78cc491386e975c10612649 100644 --- a/src/Gargantext/Core/Viz/Phylo/PhyloExport.hs +++ b/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 -