[DEBUG] Message
[gargantext.git] / src / Gargantext / Core / Viz / Graph / API.hs
index 21fac7dee62a8e6b92b05c04222cdda8707b907e..51a8a45d23c3521e378926e842307552ac7648ed 100644 (file)
@@ -9,7 +9,7 @@ Portability : POSIX
 
 -}
 
-
+{-# LANGUAGE BangPatterns      #-}
 {-# LANGUAGE OverloadedLists   #-}   -- allows to write Map and HashMap as lists
 {-# LANGUAGE TypeOperators     #-}
 
@@ -23,16 +23,18 @@ import Data.Swagger
 import Data.Text hiding (head)
 import Debug.Trace (trace)
 import GHC.Generics (Generic)
+import Gargantext.API.Admin.EnvTypes (GargJob(..), Env)
 import Gargantext.API.Admin.Orchestrator.Types
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Prelude
-import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
+import Gargantext.Core.Methods.Similarities (Similarity(..), GraphMetric(..), withMetric)
 import Gargantext.Core.NodeStory
 import Gargantext.Core.Types.Main
-import Gargantext.Core.Viz.Graph
 import Gargantext.Core.Viz.Graph.GEXF ()
 import Gargantext.Core.Viz.Graph.Tools -- (cooc2graph)
-import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+import Gargantext.Core.Viz.Graph.Types
+import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsOnlyUser)
+import Gargantext.Database.Action.Flow.Types (FlowCmdM)
 import Gargantext.Database.Action.Node (mkNodeWithParent)
 import Gargantext.Database.Admin.Config
 import Gargantext.Database.Admin.Types.Node
@@ -45,8 +47,9 @@ import Gargantext.Database.Query.Table.Node.User (getNodeUser)
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Schema.Ngrams
 import Gargantext.Prelude
+import Gargantext.Utils.Jobs (serveJobsAPI)
 import Servant
-import Servant.Job.Async
+import Servant.Job.Async (AsyncJobsAPI)
 import Servant.XML
 import qualified Data.HashMap.Strict as HashMap
 
@@ -67,10 +70,11 @@ data GraphVersions =
                 }
    deriving (Show, Generic)
 
+instance FromJSON GraphVersions
 instance ToJSON GraphVersions
 instance ToSchema GraphVersions
 
-graphAPI :: UserId -> NodeId -> GargServer GraphAPI
+graphAPI :: UserId -> NodeId -> ServerT GraphAPI (GargM Env GargError)
 graphAPI u n = getGraph         u n
           :<|> graphAsync       u n
           :<|> graphClone       u n
@@ -78,26 +82,34 @@ graphAPI u n = getGraph         u n
           :<|> graphVersionsAPI u n
 
 ------------------------------------------------------------------------
-getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
+--getGraph :: UserId -> NodeId -> GargServer HyperdataGraphAPI
+getGraph :: FlowCmdM env err m
+         => UserId
+         -> NodeId
+         -> m HyperdataGraphAPI
 getGraph _uId nId = do
   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
 
   let
     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
-    cId = maybe (panic "[G.V.G.API] Node has no parent")
-                  identity
-                  $ nodeGraph ^. node_parent_id
 
+  mcId <- getClosestParentIdByType nId NodeCorpus
+  let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
+
+  -- printDebug "[getGraph] getting list for cId" cId
   listId <- defaultList cId
-  repo <- getRepo' [listId]
+  repo <- getRepo [listId]
 
-  -- TODO Distance in Graph params
+  -- TODO Similarity in Graph params
   case graph of
     Nothing     -> do
-        let defaultMetric = Order1
-        graph' <- computeGraph cId (withMetric defaultMetric) NgramsTerms repo
-        mt     <- defaultGraphMetadata cId "Title" repo defaultMetric
+        let defaultMetric          = Order1
+        let defaultPartitionMethod = Spinglass
+        let defaultEdgesStrength   = Strong
+        let defaultBridgenessMethod = BridgenessMethod_Basic
+        graph' <- computeGraph cId defaultPartitionMethod defaultBridgenessMethod (withMetric defaultMetric) defaultEdgesStrength (NgramsTerms, NgramsTerms) repo
+        mt     <- defaultGraphMetadata cId "Title" repo defaultMetric defaultEdgesStrength
         let
           graph'' = set graph_metadata (Just mt) graph'
           hg = HyperdataGraphAPI graph'' camera
@@ -109,72 +121,107 @@ getGraph _uId nId = do
         HyperdataGraphAPI graph' camera
 
 
-recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
-recomputeGraph _uId nId maybeDistance = do
+--recomputeGraph :: UserId -> NodeId -> Maybe GraphMetric -> GargNoServer Graph
+recomputeGraph :: FlowCmdM env err m
+               => UserId
+               -> NodeId
+               -> PartitionMethod
+               -> BridgenessMethod
+               -> Maybe GraphMetric
+               -> Maybe Strength
+               -> NgramsType
+               -> NgramsType
+               -> Bool
+               -> m Graph
+recomputeGraph _uId nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt1 nt2 force = do
   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
   let
     graph  = nodeGraph ^. node_hyperdata . hyperdataGraph
     camera = nodeGraph ^. node_hyperdata . hyperdataCamera
     graphMetadata = graph ^? _Just . graph_metadata . _Just
     listVersion   = graph ^? _Just . graph_metadata . _Just . gm_list . lfg_version
-    graphMetric   = case maybeDistance of
+    graphMetric   = case maybeSimilarity of
                       Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
-                      _       -> maybeDistance
-
-  let
-    cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
-                  identity
-                  $ nodeGraph ^. node_parent_id
+                      Just _  -> maybeSimilarity
     similarity = case graphMetric of
                    Nothing -> withMetric Order1
                    Just m  -> withMetric m
 
+    strength = case maybeStrength of
+                   Nothing -> case graph ^? _Just . graph_metadata . _Just . gm_edgesStrength of
+                        Nothing  -> Strong
+                        Just  mr -> fromMaybe Strong mr
+                   Just r  -> r
+
+  mcId <- getClosestParentIdByType nId NodeCorpus
+  let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
+
   listId  <- defaultList cId
-  repo <- getRepo' [listId]
+  repo <- getRepo [listId]
   let v   = repo ^. unNodeStory . at listId . _Just . a_version
 
+  let computeG mt = do
+        !g <- computeGraph cId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo
+        let g' = set graph_metadata mt g
+        _nentries <- updateHyperdata nId (HyperdataGraph (Just g') camera)
+        pure g'
+
   case graph of
     Nothing     -> do
-      graph' <- computeGraph cId similarity NgramsTerms repo
-      mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeDistance)
-      let graph'' = set graph_metadata (Just mt) graph'
-      _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
-      pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" graph''
-
-    Just graph' -> if listVersion == Just v
+      mt     <- defaultGraphMetadata cId "Title" repo (fromMaybe Order1 maybeSimilarity) strength
+      g <- computeG $ Just mt
+      pure $ trace "[G.V.G.API.recomputeGraph] Graph empty, computed" g
+    Just graph' -> if (listVersion == Just v) && (not force)
                      then pure graph'
                      else do
-                       graph'' <- computeGraph cId similarity NgramsTerms repo
-                       let graph''' = set graph_metadata graphMetadata graph''
-                       _ <- updateHyperdata nId (HyperdataGraph (Just graph''') camera)
-                       pure $ trace "[G.V.G.API] Graph exists, recomputing" graph'''
+                       g <- computeG graphMetadata
+                       pure $ trace "[G.V.G.API] Graph exists, recomputing" g
 
 
--- TODO use Database Monad only here ?
-computeGraph :: HasNodeError err
+-- TODO remove repo
+computeGraph :: FlowCmdM env err m
              => CorpusId
-             -> Distance
-             -> NgramsType
+             -> PartitionMethod
+             -> BridgenessMethod
+             -> Similarity
+             -> Strength
+             -> (NgramsType, NgramsType)
              -> NodeListStory
-             -> Cmd err Graph
-computeGraph cId d nt repo = do
-  lId  <- defaultList cId
+             -> m Graph
+computeGraph corpusId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo = do
+  -- Getting the Node parameters
+  lId  <- defaultList corpusId
   lIds <- selectNodesWithUsername NodeList userMaster
 
-  let ngs = filterListWithRoot MapTerm
-          $ mapTermListRoot [lId] nt repo
-
-  myCooc <- HashMap.filter (>2) -- Removing the hapax (ngrams with 1 cooc)
-         <$> getCoocByNgrams (Diagonal True)
-         <$> groupNodesByNgrams ngs
-         <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (HashMap.keys ngs)
-
-  -- printDebug "myCooc" myCooc
-  -- saveAsFileDebug "debug/my-cooc" myCooc
+  -- Getting the Ngrams to compute with and grouping it according to the lists
+  let
+    groupedContextsByNgrams nt corpusId' (lists_master, lists_user) = do
+      let
+        ngs = filterListWithRoot [MapTerm] $ mapTermListRoot lists_user nt repo
+      groupNodesByNgrams ngs <$> getContextsByNgramsOnlyUser corpusId'
+                                     (lists_user <> lists_master) nt (HashMap.keys ngs)
+
+  -- Optim if nt1 == nt2 : do not compute twice
+  (m1,m2) <- do
+    m1 <- groupedContextsByNgrams nt1 corpusId (lIds, [lId])
+    if nt1 == nt2
+      then
+        pure (m1,m1)
+      else do
+        m2 <- groupedContextsByNgrams nt2 corpusId (lIds, [lId])
+        pure (m1,m2)
+
+            -- Removing the hapax (ngrams with 1 cooc)
+  let !myCooc = {- HashMap.filter (>0)
+              $ -} getCoocByNgrams'' (Diagonal True) (identity, identity) (m1,m2)
+
+  -- TODO MultiPartite Here
+  liftBase
+        $ cooc2graphWith partitionMethod bridgeMethod (MultiPartite (Partite (HashMap.keysSet m1) nt1)
+                                              (Partite (HashMap.keysSet m2) nt2)
+                                              )
+                                similarity 0 strength myCooc
 
-  graph <- liftBase $ cooc2graphWith Spinglass d 0 myCooc
-  -- saveAsFileDebug "debug/graph" graph
-  pure graph
 
 
 defaultGraphMetadata :: HasNodeError err
@@ -182,49 +229,55 @@ defaultGraphMetadata :: HasNodeError err
                      -> Text
                      -> NodeListStory
                      -> GraphMetric
+                     -> Strength
                      -> Cmd err GraphMetadata
-defaultGraphMetadata cId t repo gm = do
+defaultGraphMetadata cId t repo gm str = do
   lId  <- defaultList cId
 
-  pure $ GraphMetadata {
-      _gm_title = t
-    , _gm_metric = gm
-    , _gm_corpusId = [cId]
-    , _gm_legend = [
-          LegendField 1 "#FFF" "Cluster1"
-        , LegendField 2 "#FFF" "Cluster2"
-        , LegendField 3 "#FFF" "Cluster3"
-        , LegendField 4 "#FFF" "Cluster4"
-        ]
-      , _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
-      , _gm_startForceAtlas = True
-    }
+  pure $ GraphMetadata { _gm_title         = t
+                       , _gm_metric        = gm
+                       , _gm_edgesStrength = Just str
+                       , _gm_corpusId      = [cId]
+                       , _gm_legend = [
+                             LegendField 1 "#FFF" "Cluster1"
+                           , LegendField 2 "#FFF" "Cluster2"
+                           , LegendField 3 "#FFF" "Cluster3"
+                           , LegendField 4 "#FFF" "Cluster4"
+                           ]
+                       , _gm_list  = ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version)
+                       , _gm_startForceAtlas = True
+                       }
                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 
-
 ------------------------------------------------------------
 type GraphAsyncAPI = Summary "Recompute graph"
                      :> "recompute"
                      :> AsyncJobsAPI JobLog () JobLog
 
 
-graphAsync :: UserId -> NodeId -> GargServer GraphAsyncAPI
+graphAsync :: UserId -> NodeId -> ServerT GraphAsyncAPI (GargM Env GargError)
 graphAsync u n =
-  serveJobsAPI $
-    JobFunction (\_ log' -> graphRecompute u n (liftBase . log'))
+  serveJobsAPI RecomputeGraphJob $ \_ log' ->
+    graphRecompute u n (liftBase . log')
 
 
-graphRecompute :: UserId
+--graphRecompute :: UserId
+--               -> NodeId
+--               -> (JobLog -> GargNoServer ())
+--               -> GargNoServer JobLog
+-- TODO get Graph Metadata to recompute
+graphRecompute :: FlowCmdM env err m
+               => UserId
                -> NodeId
-               -> (JobLog -> GargNoServer ())
-               -> GargNoServer JobLog
+               -> (JobLog -> m ())
+               -> m JobLog
 graphRecompute u n logStatus = do
   logStatus JobLog { _scst_succeeded = Just 0
                    , _scst_failed    = Just 0
                    , _scst_remaining = Just 1
                    , _scst_events    = Just []
                    }
-  _g <- trace (show u) $ recomputeGraph u n Nothing
+  _g <- recomputeGraph u n Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
   pure  JobLog { _scst_succeeded = Just 1
                , _scst_failed    = Just 0
                , _scst_remaining = Just 0
@@ -239,11 +292,11 @@ type GraphVersionsAPI = Summary "Graph versions"
 
 graphVersionsAPI :: UserId -> NodeId -> GargServer GraphVersionsAPI
 graphVersionsAPI u n =
-           graphVersions n
+           graphVersions n
       :<|> recomputeVersions u n
 
-graphVersions :: NodeId -> GargNoServer GraphVersions
-graphVersions nId = do
+graphVersions :: Int -> NodeId -> GargNoServer GraphVersions
+graphVersions n nId = do
   nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
   let
     graph =  nodeGraph
@@ -257,19 +310,29 @@ graphVersions nId = do
                 . gm_list
                 . lfg_version
 
-    cId = maybe (panic "[G.V.G.API] Node has no parent")
-                  identity
-                  $ nodeGraph ^. node_parent_id
+  mcId <- getClosestParentIdByType nId NodeCorpus
+  let cId = maybe (panic "[G.V.G.API] Node has no parent") identity mcId
 
-  listId <- defaultList cId
-  repo <- getRepo' [listId]
-  let v = repo ^. unNodeStory . at listId . _Just . a_version
+  maybeListId <- defaultListMaybe cId
+  case maybeListId of
+    Nothing     -> if n <= 2
+                      then graphVersions (n+1) cId
+                      else panic "[G.V.G.API] list not found after iterations"
+
+    Just listId -> do
+      repo <- getRepo [listId]
+      let v = repo ^. unNodeStory . at listId . _Just . a_version
+      -- printDebug "graphVersions" v
 
-  pure $ GraphVersions { gv_graph = listVersion
-                       , gv_repo = v }
+      pure $ GraphVersions { gv_graph = listVersion
+                           , gv_repo = v }
 
-recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
-recomputeVersions uId nId = recomputeGraph uId nId Nothing
+--recomputeVersions :: UserId -> NodeId -> GargNoServer Graph
+recomputeVersions :: FlowCmdM env err m
+                  => UserId
+                  -> NodeId
+                  -> m Graph
+recomputeVersions uId nId = recomputeGraph uId nId Spinglass BridgenessMethod_Basic Nothing Nothing NgramsTerms NgramsTerms False
 
 ------------------------------------------------------------
 graphClone :: UserId
@@ -294,15 +357,13 @@ graphClone uId pId (HyperdataGraphAPI { _hyperdataAPIGraph = graph
       pure nId
 
 ------------------------------------------------------------
-getGraphGexf :: UserId
+--getGraphGexf :: UserId
+--             -> NodeId
+--             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
+getGraphGexf :: FlowCmdM env err m
+             => UserId
              -> NodeId
-             -> GargNoServer (Headers '[Servant.Header "Content-Disposition" Text] Graph)
+             -> m (Headers '[Servant.Header "Content-Disposition" Text] Graph)
 getGraphGexf uId nId = do
   HyperdataGraphAPI { _hyperdataAPIGraph = graph } <- getGraph uId nId
   pure $ addHeader "attachment; filename=graph.gexf" graph
-
-
-
-
-
-