LegacyMain.hs 4 KB
Newer Older
qlobbe's avatar
qlobbe committed
1 2 3 4 5 6 7 8 9 10 11
{-|
Module      : Gargantext.Core.Viz.Phylo.Main
Description : Phylomemy Main
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

12
{-# LANGUAGE MonoLocalBinds #-}
qlobbe's avatar
qlobbe committed
13 14 15 16 17 18 19 20 21 22 23 24 25
{-# LANGUAGE ViewPatterns      #-}

module Gargantext.Core.Viz.Phylo.Legacy.LegacyMain
  where

-- import Data.GraphViz
-- import qualified Data.ByteString as DB
import qualified Data.List as List
import Data.Maybe
import Data.Text (Text)
import Debug.Trace (trace)
import GHC.IO (FilePath)
import Gargantext.API.Ngrams.Tools (getTermsWith)
26
import Gargantext.API.Ngrams.Types
qlobbe's avatar
qlobbe committed
27
import Gargantext.Database.Admin.Types.Node
28 29
import Gargantext.Core.Text.Context (TermList)
import Gargantext.Core.Text.Terms.WithList
qlobbe's avatar
qlobbe committed
30 31
import Gargantext.Database.Query.Table.Node(defaultList)
import Gargantext.Prelude
32
import Gargantext.Database.Action.Flow.Types
qlobbe's avatar
qlobbe committed
33
import Gargantext.Core.Viz.LegacyPhylo hiding (Svg, Dot)
qlobbe's avatar
qlobbe committed
34 35
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
36
import Gargantext.Database.Query.Table.NodeContext (selectDocs)
qlobbe's avatar
qlobbe committed
37
import Gargantext.Core.Types
38
import Gargantext.Core (HasDBid)
qlobbe's avatar
qlobbe committed
39 40 41 42 43

-- import Gargantext.Core.Viz.Phylo.LevelMaker (toPhylo)
-- import Gargantext.Core.Viz.Phylo.Tools
-- import Gargantext.Core.Viz.Phylo.View.Export
-- import Gargantext.Core.Viz.Phylo.View.ViewMaker    -- TODO Just Maker is fine
44
import qualified Data.HashMap.Strict as HashMap
45 46
import qualified Data.Set            as Set
import qualified Data.Text           as Text
qlobbe's avatar
qlobbe committed
47 48 49

type MinSizeBranch = Int

50
flowPhylo :: (FlowCmdM env err m, HasDBid NodeType)
qlobbe's avatar
qlobbe committed
51 52 53 54 55
          => CorpusId
          -> m Phylo
flowPhylo cId = do

  list     <- defaultList cId
56
  termList <- HashMap.toList <$> getTermsWith (Text.words . unNgramsTerm) [list] NgramsTerms (Set.singleton MapTerm)
qlobbe's avatar
qlobbe committed
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126

  docs' <- catMaybes
        <$> map (\h -> (,) <$> _hd_publication_year h
                           <*> _hd_abstract h
                )
        <$> selectDocs cId

  let
    patterns = buildPatterns termList
    -- | To filter the Ngrams of a document based on the termList
    filterTerms :: Patterns -> (Date, Text) -> (Date, [Text])
    filterTerms patterns' (y,d) = (y,termsInText patterns' d)

    docs = map ((\(y,t) -> Document y t) . filterTerms patterns) docs'

  --liftBase $ flowPhylo' (List.sortOn date docs) termList l m fp
  pure $ buildPhylo (List.sortOn date docs) termList


-- TODO SortedList Document
flowPhylo' :: [Document] -> TermList      -- ^Build
           -> Level       -> MinSizeBranch -- ^View
           -> FilePath
           -> IO FilePath
flowPhylo' corpus terms l m fp = do
  let
    phylo = buildPhylo corpus terms
    phVie = viewPhylo  l m phylo

  writePhylo fp phVie


defaultQuery :: PhyloQueryBuild
defaultQuery = undefined
-- defaultQuery = defaultQueryBuild'
--   "Default Title"
--   "Default Description"

buildPhylo :: [Document] -> TermList -> Phylo
buildPhylo = trace (show defaultQuery) $ buildPhylo' defaultQuery

buildPhylo' :: PhyloQueryBuild -> [Document] -> TermList -> Phylo
buildPhylo' _ _ _ = undefined
-- buildPhylo' q corpus termList = toPhylo q corpus termList Map.empty

-- refactor 2021
-- queryView :: Level -> MinSizeBranch -> PhyloQueryView
-- queryView level _minSizeBranch = PhyloQueryView level Merge False 2
--            [BranchAge]
--            []
--            -- [SizeBranch $ SBParams minSizeBranch]
--            [BranchPeakFreq,GroupLabelCooc]
--            (Just (ByBranchAge,Asc))
--            Json Flat True

queryView :: Level -> MinSizeBranch -> PhyloQueryView
queryView _level _minSizeBranch = undefined

viewPhylo :: Level -> MinSizeBranch -> Phylo -> PhyloView
viewPhylo _l _b _phylo = undefined
-- viewPhylo l b phylo = toPhyloView (queryView l b) phylo

writePhylo :: FilePath -> PhyloView -> IO FilePath
writePhylo _fp _phview = undefined
-- writePhylo fp phview = runGraphviz (viewToDot phview) Svg fp

-- refactor 2021
-- viewPhylo2Svg :: PhyloView -> IO DB.ByteString
-- viewPhylo2Svg p = graphvizWithHandle Dot (viewToDot p) Svg DB.hGetContents