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
  13 {-# LANGUAGE FlexibleContexts  #-}
  14 {-# LANGUAGE NoImplicitPrelude #-}
  15 {-# LANGUAGE OverloadedStrings #-}
  16 {-# LANGUAGE RankNTypes        #-}
  17 {-# LANGUAGE ViewPatterns      #-}
  18
  19 module Gargantext.Viz.Phylo.Main
  20   where
  21
  22 --import Debug.Trace (trace)
  23 import qualified Data.Text as Text
  24 import Data.Maybe
  25 import Servant
  26 import GHC.IO (FilePath)
  27 import Data.GraphViz
  28 import Gargantext.Prelude
  29 import Gargantext.Text.Context (TermList)
  30 import qualified Data.Map  as Map
  31 import qualified Data.List as List
  32 import qualified Data.Set  as Set
  33 import Gargantext.Viz.Phylo.View.Export
  34 import Gargantext.Viz.Phylo.Tools
  35 import Gargantext.Viz.Phylo.LevelMaker
  36 import Gargantext.Core.Types
  37 import Gargantext.Database.Config (userMaster)
  38 import Gargantext.Database.Schema.Node (defaultList)
  39 import Gargantext.Database.Schema.NodeNode (selectDocNodes)
  40 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  41 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  42 import Gargantext.Database.Node.Select (selectNodesWithUsername)
  43 import Gargantext.Database.Flow
  44 import Gargantext.API.Ngrams.Tools (getTermsWith)
  45 -- TODO : git mv ViewMaker Maker
  46 import Gargantext.Viz.Phylo.View.ViewMaker
  47 import Gargantext.Viz.Phylo hiding (Svg, Dot)
  48 import Control.Monad.IO.Class (liftIO)
  49 import qualified Data.ByteString as DB
  50
  51 type MinSizeBranch = Int
  52
  53 flowPhylo :: FlowCmdM env ServantErr m
  54           => CorpusId
  55           -> Level -> MinSizeBranch
  56           -> FilePath
  57           -> m FilePath
  58 flowPhylo cId l m fp = do
  59
  60   list       <- defaultList cId
  61   listMaster <- selectNodesWithUsername NodeList userMaster
  62   termList <- Map.toList <$> getTermsWith Text.words [list] NgramsTerms GraphTerm
  63   --printDebug "termList" termList
  64
  65   --x <- mapTermListRoot [list] NgramsTerms
  66   --printDebug "mapTermListRoot" x
  67
  68   -- TODO optimize unwords
  69   let terms = Set.fromList
  70             $ List.concat
  71             $ map (\(a,b) -> [a] <> b) termList
  72
  73       getDate n = maybe (panic "flowPhylo") identity
  74                 $ _hyperdataDocument_publication_year
  75                 $ _node_hyperdata n
  76
  77   --printDebug "terms" terms
  78
  79   -- TODO optimize this Database function below
  80   docs' <- map (\n -> (_node_id n, getDate n)) <$> selectDocNodes cId
  81   --printDebug "docs'" docs'
  82
  83   nidTerms' <- getNodesByNgramsOnlyUser cId (listMaster <> [list])
  84                                         NgramsTerms
  85                                         (map Text.unwords $ Set.toList terms)
  86
  87   let nidTerms = Map.fromList
  88                $ List.concat
  89                $ map (\(t, ns) -> List.zip (Set.toList ns) (List.repeat t))
  90                $ Map.toList
  91                $ nidTerms'
  92
  93   let docs = List.sortOn date
  94            $ List.filter (\d -> text d /= [])
  95            $ map (\(n,d) -> Document d (maybe [] (\x -> [x])
  96            $ Map.lookup n nidTerms)) docs'
  97
  98   printDebug "docs" docs
  99   printDebug "docs" termList
 100
 101   liftIO $ flowPhylo' docs termList l m fp
 102
 103 -- TODO SortedList Document
 104 flowPhylo' :: [Document] -> TermList      -- ^Build
 105           -> Level      -> MinSizeBranch -- ^View
 106           -> FilePath
 107           -> IO FilePath
 108 flowPhylo' corpus terms l m fp = do
 109   let
 110     phylo = buildPhylo corpus terms
 111     phVie = viewPhylo  l m phylo
 112
 113   writePhylo fp phVie
 114
 115
 116 defaultQuery :: PhyloQueryBuild
 117 defaultQuery = defaultQueryBuild'
 118   "Default Title"
 119   "Default Description"
 120
 121 buildPhylo :: [Document] -> TermList -> Phylo
 122 buildPhylo = buildPhylo' defaultQuery
 123
 124 buildPhylo' :: PhyloQueryBuild -> [Document] -> TermList -> Phylo
 125 buildPhylo' q corpus termList = toPhylo q corpus termList Map.empty
 126
 127 queryView :: Level -> MinSizeBranch -> PhyloQueryView
 128 queryView level _minSizeBranch = PhyloQueryView level Merge False 2
 129            [BranchAge]
 130            []
 131            -- [SizeBranch $ SBParams minSizeBranch]
 132            [BranchPeakFreq,GroupLabelCooc]
 133            (Just (ByBranchAge,Asc))
 134            Json Flat True
 135
 136 viewPhylo :: Level -> MinSizeBranch -> Phylo -> PhyloView
 137 viewPhylo l b phylo = toPhyloView (queryView l b) phylo
 138
 139 writePhylo :: FilePath -> PhyloView -> IO FilePath
 140 writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp
 141
 142 viewPhylo2Svg :: PhyloView -> IO DB.ByteString
 143 viewPhylo2Svg p = graphvizWithHandle Dot (viewToDot p) Svg DB.hGetContents
 144