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