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