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.Process      as Shell
  50 import qualified Data.ByteString.Lazy                    as Lazy
  51 import qualified Data.List as List
  52 import qualified Data.Map.Strict  as Map
  53 import qualified Data.Set  as Set
  54
  55 --------------------------------------------------------------------
  56 getPhyloData :: PhyloId -> GargNoServer (Maybe Phylo)
  57 getPhyloData phyloId = do
  58   nodePhylo <- getNodeWith phyloId (Proxy :: Proxy HyperdataPhylo)
  59   pure $ _hp_data $ _node_hyperdata nodePhylo
  60
  61 putPhylo :: PhyloId -> GargNoServer Phylo
  62 putPhylo = undefined
  63
  64 savePhylo :: PhyloId -> GargNoServer ()
  65 savePhylo = undefined
  66
  67 --------------------------------------------------------------------
  68 phylo2dot2json :: Phylo -> IO Value
  69 phylo2dot2json phylo = do
  70
  71   let
  72     file_from    = "/tmp/fromPhylo.json"
  73     file_dot     = "/tmp/tmp.dot"
  74     file_to_json = "/tmp/toPhylo.json"
  75
  76   _ <- dotToFile file_from (toPhyloExport phylo)
  77   _ <- Shell.callProcess "dot" ["-Tdot", "-o", file_dot, file_from]
  78   _ <- Shell.callProcess "dot" ["-Txdot_json", "-o", file_to_json, file_dot]
  79
  80   maybeValue <- decodeFileStrict file_to_json
  81   print maybeValue
  82   _ <- Shell.callProcess "/bin/rm" ["-rf", file_from, file_to_json, file_dot]
  83
  84   case maybeValue of
  85     Nothing -> panic "[G.C.V.Phylo.API.phylo2dot2json] Error no file"
  86     Just v  -> pure v
  87
  88
  89
  90 flowPhyloAPI :: PhyloConfig -> CorpusId -> GargNoServer Phylo
  91 flowPhyloAPI config cId = do
  92   (_, corpus) <- corpusIdtoDocuments (timeUnit config) cId
  93   phyloWithCliques <- pure $ toPhyloWithoutLink corpus config
  94   -- writePhylo phyloWithCliquesFile phyloWithCliques
  95   pure $ toPhylo (setConfig config phyloWithCliques)
  96
  97 --------------------------------------------------------------------
  98 corpusIdtoDocuments :: TimeUnit -> CorpusId -> GargNoServer (TermList, [Document])
  99 corpusIdtoDocuments timeUnit corpusId = do
 100   docs <- selectDocNodes corpusId
 101   printDebug "docs *****" (length docs)
 102   lId  <- defaultList corpusId
 103
 104 {-
 105   (_masterUserId, _masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus
 106                                            (UserName userMaster)
 107                                            (Left "")
 108                                            (Nothing :: Maybe HyperdataCorpus)
 109   mListId <- defaultList masterCorpusId
 110   repo <- getRepo [mListId,lId]
 111 -}
 112   repo <- getRepo [lId]
 113   -- ngs_terms'   <- getContextNgrams corpusId mListId MapTerm NgramsTerms repo
 114
 115   ngs_terms    <- getContextNgrams corpusId lId MapTerm NgramsTerms repo
 116   printDebug "Size ngs_coterms *****" (length ngs_terms)
 117
 118   ngs_sources  <- getContextNgrams corpusId lId MapTerm Sources repo
 119   printDebug "Size ngs_sources Map Sources *****" (length ngs_sources)
 120
 121   termList <- getTermList lId MapTerm NgramsTerms
 122   printDebug "Size ngs_terms List Map Ngrams *****" (length <$> termList)
 123
 124   let docs'= catMaybes
 125            $ List.map (\doc
 126                         -> context2phyloDocument timeUnit doc (ngs_terms {-<> ngs_terms'-}, ngs_sources)
 127                       ) docs
 128
 129   -- printDebug "corpusIdtoDocuments" (Prelude.map date docs')
 130
 131   case termList of
 132     Nothing        -> panic "[G.C.V.Phylo.API] no termList found"
 133     Just termList' -> pure (termList', docs')
 134
 135 context2phyloDocument :: TimeUnit
 136                       -> Context HyperdataDocument
 137                       -> (Map ContextId (Set NgramsTerm), Map ContextId (Set NgramsTerm))
 138                       -> Maybe Document
 139 context2phyloDocument timeUnit context (ngs_terms, ngs_sources) = do
 140   let contextId = _context_id context
 141   (date, date') <- context2date context timeUnit
 142
 143   let
 144     toText x = Set.toList $ Set.map unNgramsTerm x
 145
 146     text'    = maybe [] toText $ Map.lookup contextId ngs_terms
 147     sources' = maybe [] toText $ Map.lookup contextId ngs_sources
 148
 149   pure $ Document date date' text' Nothing sources'
 150
 151
 152 context2date :: Context HyperdataDocument -> TimeUnit -> Maybe (Date, Text)
 153 context2date context timeUnit = do
 154   let hyperdata =  _context_hyperdata context
 155   year  <- _hd_publication_year  hyperdata
 156   month <- _hd_publication_month hyperdata
 157   day   <- _hd_publication_day   hyperdata
 158   pure (toPhyloDate year month day timeUnit, toPhyloDate' year month day timeUnit)
 159
 160
 161 ---------------
 162 -- | Dates | --
 163 ---------------
 164 toMonths :: Integer -> Int -> Int -> Date
 165 toMonths y m d = fromIntegral $ cdMonths
 166                $ diffGregorianDurationClip (fromGregorian y    m d)
 167                                            (fromGregorian 0000 0 0)
 168
 169 toDays :: Integer -> Int -> Int -> Date
 170 toDays y m d = fromIntegral
 171              $ diffDays (fromGregorian y m d) (fromGregorian 0000 0 0)
 172
 173 toPhyloDate :: Int -> Int -> Int -> TimeUnit -> Date
 174 toPhyloDate y m d tu = case tu of
 175   Year  _ _ _ -> y
 176   Month _ _ _ -> toMonths (Prelude.toInteger y) m d
 177   Week  _ _ _ -> div (toDays (Prelude.toInteger y) m d) 7
 178   Day   _ _ _ -> toDays (Prelude.toInteger y) m d
 179   _           -> panic "[G.C.V.Phylo.API] toPhyloDate"
 180
 181 toPhyloDate' :: Int -> Int -> Int -> TimeUnit -> Text
 182 toPhyloDate' y m d tu = case tu of
 183   Epoch _ _ _ -> pack $ show $ posixSecondsToUTCTime $ fromIntegral y
 184   Year  _ _ _ -> pack $ showGregorian $ fromGregorian (toInteger y) m d
 185   Month _ _ _ -> pack $ showGregorian $ fromGregorian (toInteger y) m d
 186   Week  _ _ _ -> pack $ showGregorian $ fromGregorian (toInteger y) m d
 187   Day   _ _ _ -> pack $ showGregorian $ fromGregorian (toInteger y) m d
 188
 189 -- Utils
 190
 191 writePhylo :: [Char] -> Phylo -> IO ()
 192 writePhylo path phylo = Lazy.writeFile path $ encode phylo
 193
 194
 195 readPhylo :: [Char] -> IO Phylo
 196 readPhylo path = do
 197   phyloJson <- (eitherDecode <$> readJson path) :: IO (Either String Phylo)
 198   case phyloJson of
 199     Left err -> do
 200       putStrLn err
 201       undefined
 202     Right phylo -> pure phylo
 203
 204
 205 -- | To read and decode a Json file
 206 readJson :: FilePath -> IO Lazy.ByteString
 207 readJson path = Lazy.readFile path