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.Action.Flow
  30 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  31 import Gargantext.Database.Query.Table.Node(defaultList)
  32 import Gargantext.Database.Query.Table.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   --liftBase $ 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