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