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