Skip to content

haskell-gargantext
haskell-gargantext
Commit 68362fa9 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

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

parents 16c689d4 8fb30669
Show whitespace changes
Inline Side-by-side
Showing with 70 additions and 45 deletions
bin/gargantext-phylo/Main.hs
View file @ 68362fa9
......@@ -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
View file @ 68362fa9
......@@ -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
ffrom <- readFile fileFrom
writeFile "/tmp/fileFrom.json" ffrom
fdot <- readFile fileDot
writeFile "/tmp/file.dot" fdot
fto <- readFile fileToJson
writeFile "/tmp/fileTo.json" fto
maybeValue <- decodeFileStrict fileToJson
print maybeValue
_ <- Shell.callProcess "/bin/rm" ["-rf", file_from, file_to_json, file_dot]
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
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
View file @ 68362fa9
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment