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

   1 {-|
   2 Module      : Gargantext.Core.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 ViewPatterns      #-}
  13
  14 module Gargantext.Core.Viz.Phylo.Main
  15   where
  16
  17
  18 import Data.GraphViz
  19 import qualified Data.ByteString as DB
  20 import qualified Data.List as List
  21 import qualified Data.Map  as Map
  22 import Data.Maybe
  23 import qualified Data.Text as Text
  24 import Data.Text (Text)
  25 import Debug.Trace (trace)
  26 import GHC.IO (FilePath)
  27
  28 import Gargantext.API.Ngrams.Tools (getTermsWith)
  29 import Gargantext.Core.Types
  30 import Gargantext.Database.Action.Flow
  31 import Gargantext.Database.Admin.Types.Hyperdata
  32 import Gargantext.Database.Query.Table.Node(defaultList)
  33 import Gargantext.Database.Query.Table.NodeNode (selectDocs)
  34 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  35 import Gargantext.Prelude
  36 import Gargantext.Core.Text.Context (TermList)
  37 import Gargantext.Core.Text.Terms.WithList
  38
  39 import Gargantext.Core.Viz.Phylo hiding (Svg, Dot)
  40 import Gargantext.Core.Viz.Phylo.LevelMaker (toPhylo)
  41 import Gargantext.Core.Viz.Phylo.Tools
  42 import Gargantext.Core.Viz.Phylo.View.Export
  43 import Gargantext.Core.Viz.Phylo.View.ViewMaker    -- TODO Just Maker is fine
  44
  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 MapTerm
  55
  56   docs' <- catMaybes
  57         <$> map (\h -> (,) <$> _hd_publication_year h
  58                            <*> _hd_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
  71                              $ List.concat
  72                              $ map (map Text.unwords)
  73                              $ extractTermsWithList pats txt
  74         --------------------------------------
  75
  76     docs = map ((\(y,t) -> Document y t) . filterTerms patterns) docs'
  77
  78   --liftBase $ flowPhylo' (List.sortOn date docs) termList l m fp
  79   pure $ buildPhylo (List.sortOn date docs) termList
  80
  81
  82 -- TODO SortedList Document
  83 flowPhylo' :: [Document] -> TermList      -- ^Build
  84            -> Level       -> MinSizeBranch -- ^View
  85            -> FilePath
  86            -> IO FilePath
  87 flowPhylo' corpus terms l m fp = do
  88   let
  89     phylo = buildPhylo corpus terms
  90     phVie = viewPhylo  l m phylo
  91
  92   writePhylo fp phVie
  93
  94
  95 defaultQuery :: PhyloQueryBuild
  96 defaultQuery = defaultQueryBuild'
  97   "Default Title"
  98   "Default Description"
  99
 100 buildPhylo :: [Document] -> TermList -> Phylo
 101 buildPhylo = trace (show defaultQuery) $ buildPhylo' defaultQuery
 102
 103 buildPhylo' :: PhyloQueryBuild -> [Document] -> TermList -> Phylo
 104 buildPhylo' q corpus termList = toPhylo q corpus termList Map.empty
 105
 106 queryView :: Level -> MinSizeBranch -> PhyloQueryView
 107 queryView level _minSizeBranch = PhyloQueryView level Merge False 2
 108            [BranchAge]
 109            []
 110            -- [SizeBranch $ SBParams minSizeBranch]
 111            [BranchPeakFreq,GroupLabelCooc]
 112            (Just (ByBranchAge,Asc))
 113            Json Flat True
 114
 115 viewPhylo :: Level -> MinSizeBranch -> Phylo -> PhyloView
 116 viewPhylo l b phylo = toPhyloView (queryView l b) phylo
 117
 118 writePhylo :: FilePath -> PhyloView -> IO FilePath
 119 writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp
 120
 121 viewPhylo2Svg :: PhyloView -> IO DB.ByteString
 122 viewPhylo2Svg p = graphvizWithHandle Dot (viewToDot p) Svg DB.hGetContents
 123