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 ViewPatterns      #-}
  13
  14 module Gargantext.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.Text.Context (TermList)
  37 import Gargantext.Text.Terms.WithList
  38 import Gargantext.Viz.Phylo hiding (Svg, Dot)
  39 import Gargantext.Viz.Phylo.LevelMaker
  40 import Gargantext.Viz.Phylo.Tools
  41 import Gargantext.Viz.Phylo.View.Export
  42 import Gargantext.Viz.Phylo.View.ViewMaker    -- TODO Just Maker is fine
  43
  44 type MinSizeBranch = Int
  45
  46 flowPhylo :: FlowCmdM env err m
  47           => CorpusId
  48           -> m Phylo
  49 flowPhylo cId = do
  50
  51   list       <- defaultList cId
  52   termList <- Map.toList <$> getTermsWith Text.words [list] NgramsTerms MapTerm
  53
  54   docs' <- catMaybes
  55           <$> map (\h -> (,) <$> _hd_publication_year h
  56                              <*> _hd_abstract h
  57                   )
  58           <$> selectDocs cId
  59
  60   let
  61     patterns = buildPatterns termList
  62     -- | To filter the Ngrams of a document based on the termList
  63     filterTerms :: Patterns -> (Date, Text) -> (Date, [Text])
  64     filterTerms patterns' (y,d) = (y,termsInText patterns' d)
  65       where
  66         --------------------------------------
  67         termsInText :: Patterns -> Text -> [Text]
  68         termsInText pats txt = List.nub $ List.concat $ map (map Text.unwords) $ extractTermsWithList pats txt
  69         --------------------------------------
  70
  71     docs = map ( (\(y,t) -> Document y t) . filterTerms patterns) docs'
  72
  73   --liftBase $ flowPhylo' (List.sortOn date docs) termList l m fp
  74   pure $ buildPhylo (List.sortOn date docs) termList
  75
  76
  77 -- TODO SortedList Document
  78 flowPhylo' :: [Document] -> TermList      -- ^Build
  79           -> Level      -> MinSizeBranch -- ^View
  80           -> FilePath
  81           -> IO FilePath
  82 flowPhylo' corpus terms l m fp = do
  83   let
  84     phylo = buildPhylo corpus terms
  85     phVie = viewPhylo  l m phylo
  86
  87   writePhylo fp phVie
  88
  89
  90 defaultQuery :: PhyloQueryBuild
  91 defaultQuery = defaultQueryBuild'
  92   "Default Title"
  93   "Default Description"
  94
  95 buildPhylo :: [Document] -> TermList -> Phylo
  96 buildPhylo = trace (show defaultQuery) $ buildPhylo' defaultQuery
  97
  98 buildPhylo' :: PhyloQueryBuild -> [Document] -> TermList -> Phylo
  99 buildPhylo' q corpus termList = toPhylo q corpus termList Map.empty
 100
 101 queryView :: Level -> MinSizeBranch -> PhyloQueryView
 102 queryView level _minSizeBranch = PhyloQueryView level Merge False 2
 103            [BranchAge]
 104            []
 105            -- [SizeBranch $ SBParams minSizeBranch]
 106            [BranchPeakFreq,GroupLabelCooc]
 107            (Just (ByBranchAge,Asc))
 108            Json Flat True
 109
 110 viewPhylo :: Level -> MinSizeBranch -> Phylo -> PhyloView
 111 viewPhylo l b phylo = toPhyloView (queryView l b) phylo
 112
 113 writePhylo :: FilePath -> PhyloView -> IO FilePath
 114 writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp
 115
 116 viewPhylo2Svg :: PhyloView -> IO DB.ByteString
 117 viewPhylo2Svg p = graphvizWithHandle Dot (viewToDot p) Svg DB.hGetContents
 118