]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Viz/Phylo/Main.hs
bug fix
[gargantext.git] / src / Gargantext / Viz / Phylo / Main.hs
1 {-|
2 Module : Gargantext.Viz.Phylo.Main
3 Description : Phylomemy Main
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 -}
11
12 {-# LANGUAGE FlexibleContexts #-}
13 {-# LANGUAGE NoImplicitPrelude #-}
14 {-# LANGUAGE OverloadedStrings #-}
15 {-# LANGUAGE RankNTypes #-}
16 {-# LANGUAGE ViewPatterns #-}
17
18 module Gargantext.Viz.Phylo.Main
19 where
20
21
22 import Data.GraphViz
23 import Data.Maybe
24 import Data.Text (Text)
25 import Debug.Trace (trace)
26 import GHC.IO (FilePath)
27 import Gargantext.API.Ngrams.Tools (getTermsWith)
28 import Gargantext.Core.Types
29 import Gargantext.Database.Flow
30 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
31 import Gargantext.Database.Schema.Node (defaultList)
32 import Gargantext.Database.Schema.NodeNode (selectDocs)
33 import Gargantext.Prelude
34 import Gargantext.Text.Context (TermList)
35 import Gargantext.Text.Terms.WithList
36 import Gargantext.Viz.Phylo hiding (Svg, Dot)
37 import Gargantext.Viz.Phylo.LevelMaker
38 import Gargantext.Viz.Phylo.Tools
39 import Gargantext.Viz.Phylo.View.Export
40 import Gargantext.Viz.Phylo.View.ViewMaker -- TODO Just Maker is fine
41 import qualified Data.ByteString as DB
42 import qualified Data.List as List
43 import qualified Data.Map as Map
44 import qualified Data.Text as Text
45
46 type MinSizeBranch = Int
47
48 flowPhylo :: FlowCmdM env err m
49 => CorpusId
50 -> m Phylo
51 flowPhylo cId = do
52
53 list <- defaultList cId
54 termList <- Map.toList <$> getTermsWith Text.words [list] NgramsTerms GraphTerm
55
56 docs' <- catMaybes
57 <$> map (\h -> (,) <$> _hyperdataDocument_publication_year h
58 <*> _hyperdataDocument_abstract h
59 )
60 <$> selectDocs cId
61
62 let
63 patterns = buildPatterns termList
64 -- | To filter the Ngrams of a document based on the termList
65 filterTerms :: Patterns -> (Date, Text) -> (Date, [Text])
66 filterTerms patterns' (y,d) = (y,termsInText patterns' d)
67 where
68 --------------------------------------
69 termsInText :: Patterns -> Text -> [Text]
70 termsInText pats txt = List.nub $ List.concat $ map (map Text.unwords) $ extractTermsWithList pats txt
71 --------------------------------------
72
73 docs = map ( (\(y,t) -> Document y t) . filterTerms patterns) docs'
74
75 --liftIO $ flowPhylo' (List.sortOn date docs) termList l m fp
76 pure $ buildPhylo (List.sortOn date docs) termList
77
78
79 -- TODO SortedList Document
80 flowPhylo' :: [Document] -> TermList -- ^Build
81 -> Level -> MinSizeBranch -- ^View
82 -> FilePath
83 -> IO FilePath
84 flowPhylo' corpus terms l m fp = do
85 let
86 phylo = buildPhylo corpus terms
87 phVie = viewPhylo l m phylo
88
89 writePhylo fp phVie
90
91
92 defaultQuery :: PhyloQueryBuild
93 defaultQuery = defaultQueryBuild'
94 "Default Title"
95 "Default Description"
96
97 buildPhylo :: [Document] -> TermList -> Phylo
98 buildPhylo = trace (show defaultQuery) $ buildPhylo' defaultQuery
99
100 buildPhylo' :: PhyloQueryBuild -> [Document] -> TermList -> Phylo
101 buildPhylo' q corpus termList = toPhylo q corpus termList Map.empty
102
103 queryView :: Level -> MinSizeBranch -> PhyloQueryView
104 queryView level _minSizeBranch = PhyloQueryView level Merge False 2
105 [BranchAge]
106 []
107 -- [SizeBranch $ SBParams minSizeBranch]
108 [BranchPeakFreq,GroupLabelCooc]
109 (Just (ByBranchAge,Asc))
110 Json Flat True
111
112 viewPhylo :: Level -> MinSizeBranch -> Phylo -> PhyloView
113 viewPhylo l b phylo = toPhyloView (queryView l b) phylo
114
115 writePhylo :: FilePath -> PhyloView -> IO FilePath
116 writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp
117
118 viewPhylo2Svg :: PhyloView -> IO DB.ByteString
119 viewPhylo2Svg p = graphvizWithHandle Dot (viewToDot p) Svg DB.hGetContents
120