src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.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 MonoLocalBinds #-}
  13 {-# LANGUAGE ViewPatterns      #-}
  14
  15 module Gargantext.Core.Viz.Phylo.Legacy.LegacyMain
  16   where
  17
  18 -- import Data.GraphViz
  19 -- import qualified Data.ByteString as DB
  20 import qualified Data.List as List
  21 import Data.Maybe
  22 import Data.Text (Text)
  23 import Debug.Trace (trace)
  24 import GHC.IO (FilePath)
  25 import Gargantext.API.Ngrams.Tools (getTermsWith)
  26 import Gargantext.API.Ngrams.Types
  27 import Gargantext.Database.Admin.Types.Node
  28 import Gargantext.Core.Text.Context (TermList)
  29 import Gargantext.Core.Text.Terms.WithList
  30 import Gargantext.Database.Query.Table.Node(defaultList)
  31 import Gargantext.Prelude
  32 import Gargantext.Database.Action.Flow.Types
  33 import Gargantext.Core.Viz.LegacyPhylo hiding (Svg, Dot)
  34 import Gargantext.Database.Admin.Types.Hyperdata
  35 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  36 import Gargantext.Database.Query.Table.NodeContext (selectDocs)
  37 import Gargantext.Core.Types
  38 import Gargantext.Core (HasDBid)
  39
  40 -- import Gargantext.Core.Viz.Phylo.LevelMaker (toPhylo)
  41 -- import Gargantext.Core.Viz.Phylo.Tools
  42 -- import Gargantext.Core.Viz.Phylo.View.Export
  43 -- import Gargantext.Core.Viz.Phylo.View.ViewMaker    -- TODO Just Maker is fine
  44 import qualified Data.HashMap.Strict as HashMap
  45 import qualified Data.Set            as Set
  46 import qualified Data.Text           as Text
  47
  48 type MinSizeBranch = Int
  49
  50 flowPhylo :: (FlowCmdM env err m, HasDBid NodeType)
  51           => CorpusId
  52           -> m Phylo
  53 flowPhylo cId = do
  54
  55   list     <- defaultList cId
  56   termList <- HashMap.toList <$> getTermsWith (Text.words . unNgramsTerm) [list] NgramsTerms (Set.singleton MapTerm)
  57
  58   docs' <- catMaybes
  59         <$> map (\h -> (,) <$> _hd_publication_year h
  60                            <*> _hd_abstract h
  61                 )
  62         <$> selectDocs cId
  63
  64   let
  65     patterns = buildPatterns termList
  66     -- | To filter the Ngrams of a document based on the termList
  67     filterTerms :: Patterns -> (Date, Text) -> (Date, [Text])
  68     filterTerms patterns' (y,d) = (y,termsInText patterns' d)
  69
  70     docs = map ((\(y,t) -> Document y t) . filterTerms patterns) docs'
  71
  72   --liftBase $ flowPhylo' (List.sortOn date docs) termList l m fp
  73   pure $ buildPhylo (List.sortOn date docs) termList
  74
  75
  76 -- TODO SortedList Document
  77 flowPhylo' :: [Document] -> TermList      -- ^Build
  78            -> Level       -> MinSizeBranch -- ^View
  79            -> FilePath
  80            -> IO FilePath
  81 flowPhylo' corpus terms l m fp = do
  82   let
  83     phylo = buildPhylo corpus terms
  84     phVie = viewPhylo  l m phylo
  85
  86   writePhylo fp phVie
  87
  88
  89 defaultQuery :: PhyloQueryBuild
  90 defaultQuery = undefined
  91 -- defaultQuery = defaultQueryBuild'
  92 --   "Default Title"
  93 --   "Default Description"
  94
  95 buildPhylo :: [Document] -> TermList -> Phylo
  96 buildPhylo = trace (show defaultQuery) $ buildPhylo' defaultQuery
  97
  98 buildPhylo' :: PhyloQueryBuild -> [Document] -> TermList -> Phylo
  99 buildPhylo' _ _ _ = undefined
 100 -- buildPhylo' q corpus termList = toPhylo q corpus termList Map.empty
 101
 102 -- refactor 2021
 103 -- queryView :: Level -> MinSizeBranch -> PhyloQueryView
 104 -- queryView level _minSizeBranch = PhyloQueryView level Merge False 2
 105 --            [BranchAge]
 106 --            []
 107 --            -- [SizeBranch $ SBParams minSizeBranch]
 108 --            [BranchPeakFreq,GroupLabelCooc]
 109 --            (Just (ByBranchAge,Asc))
 110 --            Json Flat True
 111
 112 queryView :: Level -> MinSizeBranch -> PhyloQueryView
 113 queryView _level _minSizeBranch = undefined
 114
 115 viewPhylo :: Level -> MinSizeBranch -> Phylo -> PhyloView
 116 viewPhylo _l _b _phylo = undefined
 117 -- viewPhylo l b phylo = toPhyloView (queryView l b) phylo
 118
 119 writePhylo :: FilePath -> PhyloView -> IO FilePath
 120 writePhylo _fp _phview = undefined
 121 -- writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp
 122
 123 -- refactor 2021
 124 -- viewPhylo2Svg :: PhyloView -> IO DB.ByteString
 125 -- viewPhylo2Svg p = graphvizWithHandle Dot (viewToDot p) Svg DB.hGetContents
 126