src/Gargantext/Core/Viz/Phylo/API/Tools.hs

   1 {-|
   2 Module      : Gargantext.Core.Viz.Phylo.API
   3 Description :
   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 module Gargantext.Core.Viz.Phylo.API.Tools
  13   where
  14
  15 import Data.Aeson (Value, decodeFileStrict, eitherDecode, encode)
  16 import Data.Map.Strict (Map)
  17 import Data.Maybe (catMaybes)
  18 import Data.Proxy
  19 import Data.Set (Set)
  20 import Data.Text (Text, pack)
  21 import Data.Time.Calendar (fromGregorian, diffGregorianDurationClip, cdMonths, diffDays, showGregorian)
  22 import Data.Time.Clock.POSIX(posixSecondsToUTCTime)
  23 import Gargantext.API.Ngrams.Prelude (getTermList)
  24 import Gargantext.API.Ngrams.Tools (getRepo)
  25 import Gargantext.API.Ngrams.Types (NgramsTerm(..))
  26 import Gargantext.API.Node.Corpus.Export (getContextNgrams)
  27 import Gargantext.API.Prelude (GargNoServer)
  28 import Gargantext.Core.Text.Context (TermList)
  29 import Gargantext.Core.Types (Context)
  30 -- import Gargantext.Core.Types.Individu (User(..))
  31 import Gargantext.Core.Types.Main (ListType(MapTerm))
  32 import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
  33 import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
  34 import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloWithoutLink)
  35 import Gargantext.Core.Viz.Phylo.PhyloTools  ({-printIOMsg, printIOComment,-} setConfig)
  36 -- import Gargantext.Database.Action.Flow (getOrMk_RootWithCorpus)
  37 -- import Gargantext.Database.Admin.Config (userMaster)
  38 -- import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
  39 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataPhylo(..))
  40 import Gargantext.Database.Admin.Types.Hyperdata.Document (HyperdataDocument(..))
  41 import Gargantext.Database.Admin.Types.Node (CorpusId, ContextId, PhyloId)
  42 import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
  43 import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
  44 import Gargantext.Database.Schema.Context
  45 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  46 import Gargantext.Database.Schema.Node
  47 import Gargantext.Prelude
  48 import Prelude
  49 import System.FilePath ((</>))
  50 import System.IO.Temp (withTempDirectory)
  51 import System.Process      as Shell
  52 import qualified Data.ByteString.Lazy                    as Lazy
  53 import qualified Data.List as List
  54 import qualified Data.Map.Strict  as Map
  55 import qualified Data.Set  as Set
  56
  57 --------------------------------------------------------------------
  58 getPhyloData :: PhyloId -> GargNoServer (Maybe Phylo)
  59 getPhyloData phyloId = do
  60   nodePhylo <- getNodeWith phyloId (Proxy :: Proxy HyperdataPhylo)
  61   pure $ _hp_data $ _node_hyperdata nodePhylo
  62
  63 putPhylo :: PhyloId -> GargNoServer Phylo
  64 putPhylo = undefined
  65
  66 savePhylo :: PhyloId -> GargNoServer ()
  67 savePhylo = undefined
  68
  69 --------------------------------------------------------------------
  70 phylo2dot2json :: Phylo -> IO Value
  71 phylo2dot2json phylo = do
  72   withTempDirectory "/tmp" "phylo" $ \dirPath -> do
  73     let fileFrom = dirPath </> "phyloFrom.dot"
  74         fileDot  = dirPath </> "phylo.dot"
  75         fileToJson = dirPath </> "output.json"
  76
  77     dotToFile fileFrom (toPhyloExport phylo)
  78
  79     Shell.callProcess "dot" ["-Tdot", "-o", fileDot, fileFrom]
  80     Shell.callProcess "dot" ["-Txdot_json", "-o", fileToJson, fileDot]
  81
  82     ffrom <- readFile fileFrom
  83     writeFile "/tmp/fileFrom.json" ffrom
  84     fdot <- readFile fileDot
  85     writeFile "/tmp/file.dot" fdot
  86     fto <- readFile fileToJson
  87     writeFile "/tmp/fileTo.json" fto
  88
  89     maybeValue <- decodeFileStrict fileToJson
  90     print maybeValue
  91
  92     case maybeValue of
  93       Nothing -> panic "[G.C.V.Phylo.API.phylo2dot2json] Error no file"
  94       Just v  -> pure v
  95
  96
  97 flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
  98 flowPhyloAPI config cId = do
  99   (_, corpus) <- corpusIdtoDocuments (timeUnit config) cId
 100   let phyloWithCliques = toPhyloWithoutLink corpus config
 101   -- writePhylo phyloWithCliquesFile phyloWithCliques
 102   pure $ toPhylo (setConfig config phyloWithCliques)
 103
 104 --------------------------------------------------------------------
 105 corpusIdtoDocuments :: TimeUnit -> CorpusId -> GargNoServer (TermList, [Document])
 106 corpusIdtoDocuments timeUnit corpusId = do
 107   docs <- selectDocNodes corpusId
 108   printDebug "docs *****" (length docs)
 109   lId  <- defaultList corpusId
 110
 111 {-
 112   (_masterUserId, _masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus
 113                                            (UserName userMaster)
 114                                            (Left "")
 115                                            (Nothing :: Maybe HyperdataCorpus)
 116   mListId <- defaultList masterCorpusId
 117   repo <- getRepo [mListId,lId]
 118 -}
 119   repo <- getRepo [lId]
 120   -- ngs_terms'   <- getContextNgrams corpusId mListId MapTerm NgramsTerms repo
 121
 122   ngs_terms    <- getContextNgrams corpusId lId MapTerm NgramsTerms repo
 123   printDebug "Size ngs_coterms *****" (length ngs_terms)
 124
 125   ngs_sources  <- getContextNgrams corpusId lId MapTerm Sources repo
 126   printDebug "Size ngs_sources Map Sources *****" (length ngs_sources)
 127
 128   termList <- getTermList lId MapTerm NgramsTerms
 129   printDebug "Size ngs_terms List Map Ngrams *****" (length <$> termList)
 130
 131   let docs'= catMaybes
 132            $ List.map (\doc
 133                         -> context2phyloDocument timeUnit doc (ngs_terms {-<> ngs_terms'-}, ngs_sources)
 134                       ) docs
 135
 136   -- printDebug "corpusIdtoDocuments" (Prelude.map date docs')
 137
 138   case termList of
 139     Nothing        -> panic "[G.C.V.Phylo.API] no termList found"
 140     Just termList' -> pure (termList', docs')
 141
 142 context2phyloDocument :: TimeUnit
 143                       -> Context HyperdataDocument
 144                       -> (Map ContextId (Set NgramsTerm), Map ContextId (Set NgramsTerm))
 145                       -> Maybe Document
 146 context2phyloDocument timeUnit context (ngs_terms, ngs_sources) = do
 147   let contextId = _context_id context
 148   (date, date') <- context2date context timeUnit
 149
 150   let
 151     toText x = Set.toList $ Set.map unNgramsTerm x
 152
 153     text'    = maybe [] toText $ Map.lookup contextId ngs_terms
 154     sources' = maybe [] toText $ Map.lookup contextId ngs_sources
 155
 156   pure $ Document date date' text' Nothing sources'
 157
 158
 159 context2date :: Context HyperdataDocument -> TimeUnit -> Maybe (Date, Text)
 160 context2date context timeUnit = do
 161   let hyperdata =  _context_hyperdata context
 162   year  <- _hd_publication_year  hyperdata
 163   month <- _hd_publication_month hyperdata
 164   day   <- _hd_publication_day   hyperdata
 165   pure (toPhyloDate year month day timeUnit, toPhyloDate' year month day timeUnit)
 166
 167
 168 ---------------
 169 -- | Dates | --
 170 ---------------
 171 toMonths :: Integer -> Int -> Int -> Date
 172 toMonths y m d = fromIntegral $ cdMonths
 173                $ diffGregorianDurationClip (fromGregorian y    m d)
 174                                            (fromGregorian 0000 0 0)
 175
 176 toDays :: Integer -> Int -> Int -> Date
 177 toDays y m d = fromIntegral
 178              $ diffDays (fromGregorian y m d) (fromGregorian 0000 0 0)
 179
 180 toPhyloDate :: Int -> Int -> Int -> TimeUnit -> Date
 181 toPhyloDate y m d tu = case tu of
 182   Year  {} -> y
 183   Month {} -> toMonths (Prelude.toInteger y) m d
 184   Week  {} -> div (toDays (Prelude.toInteger y) m d) 7
 185   Day   {} -> toDays (Prelude.toInteger y) m d
 186   _        -> panic "[G.C.V.Phylo.API] toPhyloDate"
 187
 188 toPhyloDate' :: Int -> Int -> Int -> TimeUnit -> Text
 189 toPhyloDate' y _m _d (Epoch {}) = pack $ show $ posixSecondsToUTCTime $ fromIntegral y
 190 toPhyloDate' y  m  d _          = pack $ showGregorian $ fromGregorian (toInteger y) m d
 191
 192 -- Utils
 193
 194 writePhylo :: [Char] -> Phylo -> IO ()
 195 writePhylo path phylo = Lazy.writeFile path $ encode phylo
 196
 197
 198 readPhylo :: [Char] -> IO Phylo
 199 readPhylo path = do
 200   phyloJson <- (eitherDecode <$> readJson path) :: IO (Either String Phylo)
 201   case phyloJson of
 202     Left err -> do
 203       putStrLn err
 204       undefined
 205     Right phylo -> pure phylo
 206
 207
 208 -- | To read and decode a Json file
 209 readJson :: FilePath -> IO Lazy.ByteString
 210 readJson = Lazy.readFile