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.NgramsByContext (getContextsByNgramsOnlyUser)
  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 FromJSON GraphVersions
  71 instance ToJSON GraphVersions
  72 instance ToSchema GraphVersions
  73
  74 graphAPI :: UserId -> NodeId -> GargServer GraphAPI
  75 graphAPI u n = getGraph         u n
  76           :<|> graphAsync       u n
  77           :<|> graphClone       u n
  78           :<|> getGraphGexf     u n
  79           :<|> graphVersionsAPI u n
  80
  81 ------------------------------------------------------------------------
  82 --getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
  83 getGraph :: FlowCmdM env err m
  84          => UserId
  85          -> NodeId
  86          -> m HyperdataGraphAPI
  87 getGraph _uId nId = do
  88   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
  89
  90   let
  91     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
  92     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
  93
  94   mcId <- getClosestParentIdByType nId NodeCorpus
  95   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
  96
  97   printDebug "[getGraph] getting list for cId" cId
  98   listId <- defaultList cId
  99   repo <- getRepo' [listId]
 100
 101   -- TODO Distance in Graph params
 102   case graph of
 103     Nothing     -> do
 104         let defaultMetric = Order1
 105         graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
 106         mt     <- defaultGraphMetadata cId "Title" repo defaultMetric
 107         let
 108           graph'' = set graph_metadata (Just mt) graph'
 109           hg = HyperdataGraphAPI graph'' camera
 110        -- _      <- updateHyperdata nId hg
 111         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
 112         pure $ trace "[G.V.G.API] Graph empty, computing" hg
 113
 114     Just graph' -> pure $ trace "[G.V.G.API] Graph exists, returning" $
 115         HyperdataGraphAPI graph' camera
 116
 117
 118 --recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
 119 recomputeGraph :: FlowCmdM env err m
 120                => UserId
 121                -> NodeId
 122                -> Maybe GraphMetric
 123                -> Bool
 124                -> m Graph
 125 recomputeGraph _uId nId maybeDistance force = do
 126   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 127   let
 128     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
 129     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
 130     graphMetadata = graph ^? _Just . graph_metadata . _Just
 131     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
 132     graphMetric   = case maybeDistance of
 133                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
 134                       _       -> maybeDistance
 135     similarity = case graphMetric of
 136                    Nothing -> withMetric Order1
 137                    Just m  -> withMetric m
 138
 139   mcId <- getClosestParentIdByType nId NodeCorpus
 140   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 141
 142   listId  <- defaultList cId
 143   repo <- getRepo' [listId]
 144   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 145
 146   let computeG mt = do
 147         g <- computeGraph cId similarity NgramsTerms repo
 148         let g' = set graph_metadata mt g
 149         _ <- updateHyperdata nId (HyperdataGraph (Just g') camera)
 150         pure g'
 151
 152   case graph of
 153     Nothing     -> do
 154       mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
 155       g <- computeG $ Just mt
 156       pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" g
 157     Just graph' -> if (listVersion == Just v) && (not force)
 158                      then pure graph'
 159                      else do
 160                        g <- computeG graphMetadata
 161                        pure $ trace "[G.V.G.API] Graph exists, recomputing" g
 162
 163
 164 computeGraph :: FlowCmdM env err m
 165              => CorpusId
 166              -> Distance
 167              -> NgramsType
 168              -> NodeListStory
 169              -> m Graph
 170 computeGraph cId d nt repo = do
 171   lId  <- defaultList cId
 172   lIds <- selectNodesWithUsername NodeList userMaster
 173
 174   let ngs = filterListWithRoot MapTerm
 175           $ mapTermListRoot [lId] nt repo
 176
 177   myCooc <- HashMap.filter (>1) -- Removing the hapax (ngrams with 1 cooc)
 178          -- <$> HashMap.filterWithKey (\(x,y) _ -> x /= y)
 179          -- <$> getCoocByNgrams (if d == Conditional then Diagonal True else Diagonal False)
 180          <$> getCoocByNgrams (Diagonal True)
 181          <$> groupNodesByNgrams ngs
 182          <$> getContextsByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
 183
 184   -- printDebug "myCooc" myCooc
 185   -- saveAsFileDebug "debug/my-cooc" myCooc
 186
 187   listNgrams <- getListNgrams [lId] nt
 188
 189   -- graph <- liftBase $ cooc2graphWith Bac d 0 myCooc
 190   graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
 191   -- saveAsFileDebug "debug/graph" graph
 192
 193   pure $ mergeGraphNgrams graph (Just listNgrams)
 194
 195
 196 defaultGraphMetadata :: HasNodeError err
 197                      => CorpusId
 198                      -> Text
 199                      -> NodeListStory
 200                      -> GraphMetric
 201                      -> Cmd err GraphMetadata
 202 defaultGraphMetadata cId t repo gm = do
 203   lId  <- defaultList cId
 204
 205   pure $ GraphMetadata {
 206       _gm_title = t
 207     , _gm_metric = gm
 208     , _gm_corpusId = [cId]
 209     , _gm_legend = [
 210           LegendField 1 "#FFF" "Cluster1"
 211         , LegendField 2 "#FFF" "Cluster2"
 212         , LegendField 3 "#FFF" "Cluster3"
 213         , LegendField 4 "#FFF" "Cluster4"
 214         ]
 215       , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
 216       , _gm_startForceAtlas = True
 217     }
 218                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 219
 220 ------------------------------------------------------------
 221 type GraphAsyncAPI = Summary "Recompute graph"
 222                      :> "recompute"
 223                      :> AsyncJobsAPI JobLog () JobLog
 224
 225
 226 graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
 227 graphAsync u n =
 228   serveJobsAPI $
 229     JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
 230
 231
 232 --graphRecompute :: UserId
 233 --               -> NodeId
 234 --               -> (JobLog -> GargNoServer ())
 235 --               -> GargNoServer JobLog
 236 graphRecompute :: FlowCmdM env err m
 237                => UserId
 238                -> NodeId
 239                -> (JobLog -> m ())
 240                -> m JobLog
 241 graphRecompute u n logStatus = do
 242   logStatus JobLog { _scst_succeeded = Just 0
 243                    , _scst_failed    = Just 0
 244                    , _scst_remaining = Just 1
 245                    , _scst_events    = Just []
 246                    }
 247   _g <- trace (show u) $ recomputeGraph u n Nothing False
 248   pure  JobLog { _scst_succeeded = Just 1
 249                , _scst_failed    = Just 0
 250                , _scst_remaining = Just 0
 251                , _scst_events    = Just []
 252                }
 253
 254 ------------------------------------------------------------
 255 type GraphVersionsAPI = Summary "Graph versions"
 256                         :> Get '[JSON] GraphVersions
 257                    :<|> Summary "Recompute graph version"
 258                         :> Post '[JSON] Graph
 259
 260 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 261 graphVersionsAPI u n =
 262            graphVersions 0 n
 263       :<|> recomputeVersions u n
 264
 265 graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
 266 graphVersions n nId = do
 267   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 268   let
 269     graph =  nodeGraph
 270           ^. node_hyperdata
 271            . hyperdataGraph
 272
 273     listVersion =  graph
 274                 ^? _Just
 275                 . graph_metadata
 276                 . _Just
 277                 . gm_list
 278                 . lfg_version
 279
 280   mcId <- getClosestParentIdByType nId NodeCorpus
 281   let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 282
 283   maybeListId <- defaultListMaybe cId
 284   case maybeListId of
 285     Nothing     -> if n <= 2
 286                       then graphVersions (n+1) cId
 287                       else panic "[G.V.G.API] list not found after iterations"
 288
 289     Just listId -> do
 290       repo <- getRepo' [listId]
 291       let v = repo ^. unNodeStory . at listId . _Just . a_version
 292       printDebug "graphVersions" v
 293
 294       pure $ GraphVersions { gv_graph = listVersion
 295                            , gv_repo = v }
 296
 297 --recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
 298 recomputeVersions :: FlowCmdM env err m
 299                   => UserId
 300                   -> NodeId
 301                   -> m Graph
 302 recomputeVersions uId nId = recomputeGraph uId nId Nothing False
 303
 304 ------------------------------------------------------------
 305 graphClone :: UserId
 306            -> NodeId
 307            -> HyperdataGraphAPI
 308            -> GargNoServer NodeId
 309 graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
 310                                       , _hyperdataAPICamera = camera }) = do
 311   let nodeType = NodeGraph
 312   nodeUser <- getNodeUser (NodeId uId)
 313   nodeParent <- getNodeWith pId (Proxy :: Proxy HyperdataGraph)
 314   let uId' = nodeUser ^. node_user_id
 315   nIds <- mkNodeWithParent nodeType (Just pId) uId' $ nodeParent ^. node_name
 316   case nIds of
 317     [] -> pure pId
 318     (nId:_) -> do
 319       let graphP = graph
 320       let graphP' = set (graph_metadata . _Just . gm_startForceAtlas) False graphP
 321
 322       _ <- updateHyperdata nId (HyperdataGraph (Just graphP') camera)
 323
 324       pure nId
 325
 326 ------------------------------------------------------------
 327 --getGraphGexf :: UserId
 328 --             -> NodeId
 329 --             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 330 getGraphGexf :: FlowCmdM env err m
 331              => UserId
 332              -> NodeId
 333              -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 334 getGraphGexf uId nId = do
 335   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
 336   pure $ addHeader "attachment; filename=graph.gexf" graph
 337