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 Debug.Trace (trace)
  22 import qualified Data.Text as Text
  23 import Data.Text (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 Gargantext.Viz.Phylo.View.Export
  33 import Gargantext.Viz.Phylo.Tools
  34 import Gargantext.Viz.Phylo.LevelMaker
  35 import Gargantext.Core.Types
  36 import Gargantext.Text.Terms.WithList
  37 -- import Gargantext.Database.Config (userMaster)
  38 import Gargantext.Database.Schema.Node (defaultList)
  39 import Gargantext.Database.Schema.NodeNode (selectDocs)
  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
  70   docs' <- catMaybes <$> map (\h -> (,) <$> _hyperdataDocument_publication_year h
  71                           <*> _hyperdataDocument_abstract h
  72                           ) <$> selectDocs cId
  73
  74   let patterns = buildPatterns termList
  75   let docs = map ( (\(y,t) -> Document y t) . filterTerms patterns) docs'
  76   --printDebug "docs" docs
  77   --printDebug "docs" termList
  78
  79   liftIO $ flowPhylo' (List.sortOn date docs) termList l m fp
  80
  81
  82
  83
  84 parse :: TermList -> [(Date, Text)] -> IO [Document]
  85 parse l c = do
  86   let patterns = buildPatterns l
  87   pure $ map ( (\(y,t) -> Document y t) . filterTerms patterns) c
  88
  89
  90 -- | To filter the Ngrams of a document based on the termList
  91 filterTerms :: Patterns -> (Date, Text) -> (Date, [Text])
  92 filterTerms patterns (y,d) = (y,termsInText patterns d)
  93   where
  94     --------------------------------------
  95     termsInText :: Patterns -> Text -> [Text]
  96     termsInText pats txt = List.nub $ List.concat $ map (map Text.unwords) $ extractTermsWithList pats txt
  97     --------------------------------------
  98
  99
 100 -- TODO SortedList Document
 101 flowPhylo' :: [Document] -> TermList      -- ^Build
 102           -> Level      -> MinSizeBranch -- ^View
 103           -> FilePath
 104           -> IO FilePath
 105 flowPhylo' corpus terms l m fp = do
 106   let
 107     phylo = buildPhylo corpus terms
 108     phVie = viewPhylo  l m phylo
 109
 110   writePhylo fp phVie
 111
 112
 113 defaultQuery :: PhyloQueryBuild
 114 defaultQuery = defaultQueryBuild'
 115   "Default Title"
 116   "Default Description"
 117
 118 buildPhylo :: [Document] -> TermList -> Phylo
 119 buildPhylo = trace (show defaultQuery) $ buildPhylo' defaultQuery
 120
 121 buildPhylo' :: PhyloQueryBuild -> [Document] -> TermList -> Phylo
 122 buildPhylo' q corpus termList = toPhylo q corpus termList Map.empty
 123
 124 queryView :: Level -> MinSizeBranch -> PhyloQueryView
 125 queryView level _minSizeBranch = PhyloQueryView level Merge False 2
 126            [BranchAge]
 127            []
 128            -- [SizeBranch $ SBParams minSizeBranch]
 129            [BranchPeakFreq,GroupLabelCooc]
 130            (Just (ByBranchAge,Asc))
 131            Json Flat True
 132
 133 viewPhylo :: Level -> MinSizeBranch -> Phylo -> PhyloView
 134 viewPhylo l b phylo = toPhyloView (queryView l b) phylo
 135
 136 writePhylo :: FilePath -> PhyloView -> IO FilePath
 137 writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp
 138
 139 viewPhylo2Svg :: PhyloView -> IO DB.ByteString
 140 viewPhylo2Svg p = graphvizWithHandle Dot (viewToDot p) Svg DB.hGetContents
 141