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