src/Gargantext/Core/Viz/Graph/API.hs

   1 {-|
   2 Module      : Gargantext.Core.Viz.Graph
   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 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
  13 {-# LANGUAGE TypeOperators     #-}
  14
  15 module Gargantext.Core.Viz.Graph.API
  16   where
  17
  18 import Control.Lens (set, (^.), _Just, (^?), at)
  19 import Data.Aeson
  20 import Data.Maybe (fromMaybe)
  21 import Data.Swagger
  22 import Data.Text hiding (head)
  23 import Debug.Trace (trace)
  24 import GHC.Generics (Generic)
  25 import Gargantext.API.Admin.Orchestrator.Types
  26 import Gargantext.API.Ngrams.Tools
  27 import Gargantext.API.Prelude
  28 import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
  29 import Gargantext.Core.NodeStory
  30 import Gargantext.Core.Types.Main
  31 import Gargantext.Core.Viz.Graph
  32 import Gargantext.Core.Viz.Graph.GEXF ()
  33 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
  34 import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  35 import Gargantext.Database.Action.Flow.Types (FlowCmdM)
  36 import Gargantext.Database.Action.Node (mkNodeWithParent)
  37 import Gargantext.Database.Admin.Config
  38 import Gargantext.Database.Admin.Types.Node
  39 import Gargantext.Database.Prelude (Cmd)
  40 import Gargantext.Database.Query.Table.Node
  41 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  42 import Gargantext.Database.Query.Table.Node.Select
  43 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  44 import Gargantext.Database.Query.Table.Node.User (getNodeUser)
  45 import Gargantext.Database.Schema.Node
  46 import Gargantext.Database.Schema.Ngrams
  47 import Gargantext.Prelude
  48 import Servant
  49 import Servant.Job.Async
  50 import Servant.XML
  51 import qualified Data.HashMap.Strict as HashMap
  52
  53 ------------------------------------------------------------------------
  54 -- | There is no Delete specific API for Graph since it can be deleted
  55 -- as simple Node.
  56 type GraphAPI   =  Get  '[JSON] HyperdataGraphAPI
  57               :<|> "async" :> GraphAsyncAPI
  58               :<|> "clone"
  59                    :> ReqBody '[JSON] HyperdataGraphAPI
  60                    :> Post '[JSON] NodeId
  61               :<|> "gexf" :> Get '[XML] (Headers '[Servant.Header "Content-Disposition" Text] Graph)
  62               :<|> "versions" :> GraphVersionsAPI
  63
  64 data GraphVersions =
  65   GraphVersions { gv_graph :: Maybe Int
  66                 , gv_repo :: Int
  67                 }
  68    deriving (Show, Generic)
  69
  70 instance ToJSON GraphVersions
  71 instance ToSchema GraphVersions
  72
  73 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  74 graphAPI u n = getGraph         u n
  75           :<|> graphAsync       u n
  76           :<|> graphClone       u n
  77           :<|> getGraphGexf     u n
  78           :<|> graphVersionsAPI u n
  79
  80 ------------------------------------------------------------------------
  81 --getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
  82 getGraph :: FlowCmdM env err m
  83          => UserId
  84          -> NodeId
  85          -> m HyperdataGraphAPI
  86 getGraph _uId nId = do
  87   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  88
  89   let
  90     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  91     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  92
  93   mcId <- getClosestParentIdByType nId NodeCorpus
  94   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
  95
  96   printDebug "[getGraph] getting list for cId" cId
  97   listId <- defaultList cId
  98   repo <- getRepo' [listId]
  99
 100   -- TODO Distance in Graph params
 101   case graph of
 102     Nothing     -> do
 103         let defaultMetric = Order1
 104         graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
 105         mt     <- defaultGraphMetadata cId "Title" repo defaultMetric
 106         let
 107           graph'' = set graph_metadata (Just mt) graph'
 108           hg = HyperdataGraphAPI graph'' camera
 109        -- _      <- updateHyperdata nId hg
 110         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 111         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 112
 113     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 114         HyperdataGraphAPI graph' camera
 115
 116
 117 --recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
 118 recomputeGraph :: FlowCmdM env err m
 119                => UserId
 120                -> NodeId
 121                -> Maybe GraphMetric
 122                -> m Graph
 123 recomputeGraph _uId nId maybeDistance = do
 124   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 125   let
 126     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 127     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 128     graphMetadata = graph ^? _Just . graph_metadata . _Just
 129     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 130     graphMetric   = case maybeDistance of
 131                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
 132                       _       -> maybeDistance
 133     similarity = case graphMetric of
 134                    Nothing -> withMetric Order1
 135                    Just m  -> withMetric m
 136
 137   mcId <- getClosestParentIdByType nId NodeCorpus
 138   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 139
 140   listId  <- defaultList cId
 141   repo <- getRepo' [listId]
 142   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 143
 144   case graph of
 145     Nothing     -> do
 146       graph' <- computeGraph cId similarity NgramsTerms repo
 147       mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
 148       let graph'' = set graph_metadata (Just mt) graph'
 149       _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 150       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
 151
 152     Just graph' -> if listVersion == Just v
 153                      then pure graph'
 154                      else do
 155                        graph'' <- computeGraph cId similarity NgramsTerms repo
 156                        let graph''' = set graph_metadata graphMetadata graph''
 157                        _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
 158                        pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
 159
 160
 161 computeGraph :: FlowCmdM env err m
 162              => CorpusId
 163              -> Distance
 164              -> NgramsType
 165              -> NodeListStory
 166              -> m Graph
 167 computeGraph cId d nt repo = do
 168   lId  <- defaultList cId
 169   lIds <- selectNodesWithUsername NodeList userMaster
 170
 171   let ngs = filterListWithRoot MapTerm
 172           $ mapTermListRoot [lId] nt repo
 173
 174   myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
 175          -- <$> HashMap.filterWithKey (\(x,y) _ -> x /= y)
 176          -- <$> getCoocByNgrams (if d == Conditional then Diagonal True else Diagonal False)
 177          <$> getCoocByNgrams (Diagonal True)
 178          <$> groupNodesByNgrams ngs
 179          <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 180
 181   -- printDebug "myCooc" myCooc
 182   -- saveAsFileDebug "debug/my-cooc" myCooc
 183
 184   listNgrams <- getListNgrams [lId] nt
 185
 186   -- graph <- liftBase $ cooc2graphWith Bac d 0 myCooc
 187   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 188   -- saveAsFileDebug "debug/graph" graph
 189
 190   pure $ mergeGraphNgrams graph (Just listNgrams)
 191
 192
 193 defaultGraphMetadata :: HasNodeError err
 194                      => CorpusId
 195                      -> Text
 196                      -> NodeListStory
 197                      -> GraphMetric
 198                      -> Cmd err GraphMetadata
 199 defaultGraphMetadata cId t repo gm = do
 200   lId  <- defaultList cId
 201
 202   pure $ GraphMetadata {
 203       _gm_title = t
 204     , _gm_metric = gm
 205     , _gm_corpusId = [cId]
 206     , _gm_legend = [
 207           LegendField 1 "#FFF" "Cluster1"
 208         , LegendField 2 "#FFF" "Cluster2"
 209         , LegendField 3 "#FFF" "Cluster3"
 210         , LegendField 4 "#FFF" "Cluster4"
 211         ]
 212       , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 213       , _gm_startForceAtlas = True
 214     }
 215                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 216
 217 ------------------------------------------------------------
 218 type GraphAsyncAPI = Summary "Recompute graph"
 219                      :> "recompute"
 220                      :> AsyncJobsAPI JobLog () JobLog
 221
 222
 223 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 224 graphAsync u n =
 225   serveJobsAPI $
 226     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 227
 228
 229 --graphRecompute :: UserId
 230 --               -> NodeId
 231 --               -> (JobLog -> GargNoServer ())
 232 --               -> GargNoServer JobLog
 233 graphRecompute :: FlowCmdM env err m
 234                => UserId
 235                -> NodeId
 236                -> (JobLog -> m ())
 237                -> m JobLog
 238 graphRecompute u n logStatus = do
 239   logStatus JobLog { _scst_succeeded = Just 0
 240                    , _scst_failed    = Just 0
 241                    , _scst_remaining = Just 1
 242                    , _scst_events    = Just []
 243                    }
 244   _g <- trace (show u) $ recomputeGraph u n Nothing
 245   pure  JobLog { _scst_succeeded = Just 1
 246                , _scst_failed    = Just 0
 247                , _scst_remaining = Just 0
 248                , _scst_events    = Just []
 249                }
 250
 251 ------------------------------------------------------------
 252 type GraphVersionsAPI = Summary "Graph versions"
 253                         :> Get '[JSON] GraphVersions
 254                    :<|> Summary "Recompute graph version"
 255                         :> Post '[JSON] Graph
 256
 257 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 258 graphVersionsAPI u n =
 259            graphVersions 0 n
 260       :<|> recomputeVersions u n
 261
 262 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 263 graphVersions n nId = do
 264   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 265   let
 266     graph =  nodeGraph
 267           ^. node_hyperdata
 268            . hyperdataGraph
 269
 270     listVersion =  graph
 271                 ^? _Just
 272                 . graph_metadata
 273                 . _Just
 274                 . gm_list
 275                 . lfg_version
 276
 277   mcId <- getClosestParentIdByType nId NodeCorpus
 278   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 279
 280   maybeListId <- defaultListMaybe cId
 281   case maybeListId of
 282     Nothing     -> if n <= 2
 283                       then graphVersions (n+1) cId
 284                       else panic "[G.V.G.API] list not found after iterations"
 285
 286     Just listId -> do
 287       repo <- getRepo' [listId]
 288       let v = repo ^. unNodeStory . at listId . _Just . a_version
 289       printDebug "graphVersions" v
 290
 291       pure $ GraphVersions { gv_graph = listVersion
 292                            , gv_repo = v }
 293
 294 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 295 recomputeVersions :: FlowCmdM env err m
 296                   => UserId
 297                   -> NodeId
 298                   -> m Graph
 299 recomputeVersions uId nId = recomputeGraph uId nId Nothing
 300
 301 ------------------------------------------------------------
 302 graphClone :: UserId
 303            -> NodeId
 304            -> HyperdataGraphAPI
 305            -> GargNoServer NodeId
 306 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 307                                       , _hyperdataAPICamera = camera }) = do
 308   let nodeType = NodeGraph
 309   nodeUser <- getNodeUser (NodeId uId)
 310   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 311   let uId' = nodeUser ^. node_user_id
 312   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 313   case nIds of
 314     [] -> pure pId
 315     (nId:_) -> do
 316       let graphP = graph
 317       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 318
 319       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 320
 321       pure nId
 322
 323 ------------------------------------------------------------
 324 --getGraphGexf :: UserId
 325 --             -> NodeId
 326 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 327 getGraphGexf :: FlowCmdM env err m
 328              => UserId
 329              -> NodeId
 330              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 331 getGraphGexf uId nId = do
 332   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 333   pure $ addHeader "attachment; filename=graph.gexf" graph
 334