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